packages feed

Cabal 1.22.8.0 → 3.16.1.0

raw patch · 366 files changed

Files

Cabal.cabal view
@@ -1,15 +1,14 @@-name: Cabal-version: 1.22.8.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: https://github.com/haskell/cabal/issues-synopsis: A framework for packaging Haskell software+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@@ -17,188 +16,125 @@   .   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: Simple--- 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.--extra-source-files:-  README.md tests/README.md changelog-  doc/developing-packages.markdown doc/index.markdown-  doc/installing-packages.markdown-  doc/misc.markdown+category:       Distribution+build-type:     Simple+-- If we use a new Cabal feature, this needs to be changed to Custom so+-- we can bootstrap. -  -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':-  tests/PackageTests/BenchmarkExeV10/Foo.hs-  tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs-  tests/PackageTests/BenchmarkExeV10/my.cabal-  tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal-  tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs-  tests/PackageTests/BenchmarkStanza/my.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal-  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal-  tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs-  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal-  tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs-  tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal-  tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs-  tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs-  tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal-  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs-  tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal-  tests/PackageTests/CMain/Bar.hs-  tests/PackageTests/CMain/Setup.hs-  tests/PackageTests/CMain/foo.c-  tests/PackageTests/CMain/my.cabal-  tests/PackageTests/DeterministicAr/Lib.hs-  tests/PackageTests/DeterministicAr/my.cabal-  tests/PackageTests/EmptyLib/empty/empty.cabal-  tests/PackageTests/Haddock/CPP.hs-  tests/PackageTests/Haddock/Literate.lhs-  tests/PackageTests/Haddock/NoCPP.hs-  tests/PackageTests/Haddock/Simple.hs-  tests/PackageTests/Haddock/my.cabal-  tests/PackageTests/OrderFlags/Foo.hs-  tests/PackageTests/OrderFlags/my.cabal-  tests/PackageTests/PathsModule/Executable/Main.hs-  tests/PackageTests/PathsModule/Executable/my.cabal-  tests/PackageTests/PathsModule/Library/my.cabal-  tests/PackageTests/PreProcess/Foo.hsc-  tests/PackageTests/PreProcess/Main.hs-  tests/PackageTests/PreProcess/my.cabal-  tests/PackageTests/ReexportedModules/ReexportedModules.cabal-  tests/PackageTests/TemplateHaskell/dynamic/Exe.hs-  tests/PackageTests/TemplateHaskell/dynamic/Lib.hs-  tests/PackageTests/TemplateHaskell/dynamic/TH.hs-  tests/PackageTests/TemplateHaskell/dynamic/my.cabal-  tests/PackageTests/TemplateHaskell/profiling/Exe.hs-  tests/PackageTests/TemplateHaskell/profiling/Lib.hs-  tests/PackageTests/TemplateHaskell/profiling/TH.hs-  tests/PackageTests/TemplateHaskell/profiling/my.cabal-  tests/PackageTests/TemplateHaskell/vanilla/Exe.hs-  tests/PackageTests/TemplateHaskell/vanilla/Lib.hs-  tests/PackageTests/TemplateHaskell/vanilla/TH.hs-  tests/PackageTests/TemplateHaskell/vanilla/my.cabal-  tests/PackageTests/TestOptions/TestOptions.cabal-  tests/PackageTests/TestOptions/test-TestOptions.hs-  tests/PackageTests/TestStanza/my.cabal-  tests/PackageTests/TestSuiteExeV10/Foo.hs-  tests/PackageTests/TestSuiteExeV10/my.cabal-  tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs-  tests/Setup.hs-  tests/hackage/check.sh-  tests/hackage/download.sh-  tests/hackage/unpack.sh-  tests/misc/ghc-supported-languages.hs+extra-doc-files:+  README.md ChangeLog.md  source-repository head   type:     git   location: https://github.com/haskell/cabal/   subdir:   Cabal -flag bundled-binary-generic+flag git-rev+  description: include Git revision hash in version   default: False+  manual: True  library+  default-language: Haskell2010+  hs-source-dirs: src+   build-depends:-    base       >= 4.4 && < 5,-    deepseq    >= 1.3 && < 1.5,-    filepath   >= 1   && < 1.5,-    directory  >= 1   && < 1.3,-    process    >= 1.1.0.1 && < 1.3,-    time       >= 1.1 && < 1.6,-    containers >= 0.1 && < 0.6,-    array      >= 0.1 && < 0.6,-    pretty     >= 1   && < 1.2,-    bytestring >= 0.9+    , Cabal-syntax ^>= 3.16.1.0+    , array      >= 0.4.0.1  && < 0.6+    , base       >= 4.13     && < 5+    , bytestring >= 0.10.0.0 && < 0.13+    , containers >= 0.5.0.0  && < 0.9+    , deepseq    >= 1.3.0.1  && < 1.7+    , directory  >= 1.2      && < 1.4+    , filepath   >= 1.3.0.1  && < 1.6+    , pretty     >= 1.1.1    && < 1.2+    , process    >= 1.2.1.0  && < 1.7+    , time       >= 1.4.0.1  && < 1.16 -  if flag(bundled-binary-generic)-    build-depends: binary >= 0.5 && < 0.7+  if os(windows)+    build-depends:+      , Win32 >= 2.3.0.0 && < 2.15   else-    build-depends: binary >= 0.7 && < 0.9--  -- Needed for GHC.Generics before GHC 7.6-  if impl(ghc < 7.6)-    build-depends: ghc-prim >= 0.2 && < 0.3+    build-depends:+      , unix  >= 2.8.6.0 && < 2.9 -  if !os(windows)+  if flag(git-rev)     build-depends:-      unix >= 2.0 && < 2.8+      , githash ^>= 0.1.7.0+    cpp-options: -DGIT_REV -  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs+  ghc-options:+    -Wall+    -fno-ignore-asserts+    -Wtabs+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -Wno-unticked-promoted-constructors +  if impl(ghc >= 8.0)+    ghc-options: -Wcompat -Wnoncanonical-monad-instances++  if impl(ghc >= 8.0) && impl(ghc < 8.8)+    ghc-options: -Wnoncanonical-monadfail-instances+   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.Exception-    Distribution.Compat.ReadP-    Distribution.Compiler-    Distribution.InstalledPackageInfo-    Distribution.License+    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.ModuleName-    Distribution.Package-    Distribution.PackageDescription     Distribution.PackageDescription.Check-    Distribution.PackageDescription.Configuration-    Distribution.PackageDescription.Parse-    Distribution.PackageDescription.PrettyPrint-    Distribution.PackageDescription.Utils-    Distribution.ParseUtils     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.HaskellSuite+    Distribution.Simple.Glob+    Distribution.Simple.Glob.Internal     Distribution.Simple.Hpc     Distribution.Simple.Install     Distribution.Simple.InstallDirs-    Distribution.Simple.JHC-    Distribution.Simple.LHC+    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@@ -208,13 +144,16 @@     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@@ -222,107 +161,256 @@     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.System     Distribution.TestSuite-    Distribution.Text+    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.Version+    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:+    -- 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.Compat.Binary+    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.TempFile+    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.IPI641-    Distribution.Simple.GHC.IPI642     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 -  if flag(bundled-binary-generic)-    other-modules:-      Distribution.Compat.Binary.Class-      Distribution.Compat.Binary.Generic--  default-language: Haskell98-  default-extensions: CPP---- Small, fast running tests.-test-suite unit-tests-  type: exitcode-stdio-1.0-  hs-source-dirs: tests-  other-modules:-    UnitTests.Distribution.Compat.CreatePipe-    UnitTests.Distribution.Compat.ReadP-    UnitTests.Distribution.Utils.NubList-  main-is: UnitTests.hs-  build-depends:-    base,-    test-framework,-    test-framework-hunit,-    test-framework-quickcheck2,-    HUnit,-    QuickCheck < 2.9,-    Cabal-  ghc-options: -Wall-  default-language: Haskell98+  autogen-modules:+    Paths_Cabal --- Large, system tests that build packages.-test-suite package-tests-  type: exitcode-stdio-1.0-  main-is: PackageTests.hs-  other-modules:-    PackageTests.BenchmarkExeV10.Check-    PackageTests.BenchmarkOptions.Check-    PackageTests.BenchmarkStanza.Check-    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.SameDepsAllRound.Check-    PackageTests.BuildDeps.TargetSpecificDeps1.Check-    PackageTests.BuildDeps.TargetSpecificDeps2.Check-    PackageTests.BuildDeps.TargetSpecificDeps3.Check-    PackageTests.BuildTestSuiteDetailedV09.Check-    PackageTests.CMain.Check-    PackageTests.DeterministicAr.Check-    PackageTests.EmptyLib.Check-    PackageTests.Haddock.Check-    PackageTests.OrderFlags.Check-    PackageTests.PackageTester-    PackageTests.PathsModule.Executable.Check-    PackageTests.PathsModule.Library.Check-    PackageTests.PreProcess.Check-    PackageTests.ReexportedModules.Check-    PackageTests.TemplateHaskell.Check-    PackageTests.TestOptions.Check-    PackageTests.TestStanza.Check-    PackageTests.TestSuiteExeV10.Check-  hs-source-dirs: tests-  build-depends:-    base,-    containers,-    test-framework,-    test-framework-quickcheck2 >= 0.2.12,-    test-framework-hunit,-    HUnit,-    QuickCheck >= 2.1.0.1 && < 2.9,-    Cabal,-    process,-    directory,-    filepath,-    extensible-exceptions,-    bytestring,-    regex-posix,-    old-time-  if !os(windows)-    build-depends: unix-  ghc-options: -Wall-  default-extensions: CPP-  default-language: Haskell98+  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/Binary.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}--#ifndef MIN_VERSION_binary-#define MIN_VERSION_binary(x, y, z) 0-#endif--module Distribution.Compat.Binary-       ( decodeOrFailIO-#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)-       , module Data.Binary-#else-       , Binary(..)-       , decode, encode-#endif-       ) where--import Control.Exception (ErrorCall(..), catch, evaluate)-import Data.ByteString.Lazy (ByteString)--#if __GLASGOW_HASKELL__ < 706-import Prelude hiding (catch)-#endif--#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0)--import Data.Binary--#else--import Data.Binary.Get-import Data.Binary.Put--import Distribution.Compat.Binary.Class-import Distribution.Compat.Binary.Generic ()---- | Decode a value from a lazy ByteString, reconstructing the original structure.----decode :: Binary a => ByteString -> a-decode = runGet get---- | Encode a value using binary serialisation to a lazy ByteString.----encode :: Binary a => a -> ByteString-encode = runPut . put-{-# INLINE encode #-}--#endif--decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)-decodeOrFailIO bs =-  catch (evaluate (decode bs) >>= return . Right)-  $ \(ErrorCall str) -> return $ Left str
− Distribution/Compat/Binary/Class.hs 
@@ -1,530 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DefaultSignatures #-}--------------------------------------------------------------------------------- |--- Module      : Distribution.Compat.Binary.Class--- Copyright   : Lennart Kolmodin--- License     : BSD3-style (see LICENSE)------ Maintainer  : Lennart Kolmodin <kolmodin@gmail.com>--- Stability   : unstable--- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances------ Typeclass and instances for binary serialization.-----------------------------------------------------------------------------------module Distribution.Compat.Binary.Class (--    -- * The Binary class-      Binary(..)--    -- * Support for generics-    , GBinary(..)--    ) where--import Data.Word--import Data.Binary.Put-import Data.Binary.Get--import Control.Monad-import Foreign--import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as L--import Data.Char    (chr,ord)-import Data.List    (unfoldr)---- And needed for the instances:-import qualified Data.ByteString as B-import qualified Data.Map        as Map-import qualified Data.Set        as Set-import qualified Data.IntMap     as IntMap-import qualified Data.IntSet     as IntSet-import qualified Data.Ratio      as R--import qualified Data.Tree as T--import Data.Array.Unboxed--import GHC.Generics------- This isn't available in older Hugs or older GHC----#if __GLASGOW_HASKELL__ >= 606-import qualified Data.Sequence as Seq-import qualified Data.Foldable as Fold-#endif----------------------------------------------------------------------------class GBinary f where-    gput :: f t -> Put-    gget :: Get (f t)---- | The 'Binary' class provides 'put' and 'get', methods to encode and--- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and--- 'Show' classes for textual representation of Haskell types, and is--- suitable for serialising Haskell values to disk, over the network.------ For decoding and generating simple external binary formats (e.g. C--- structures), Binary may be used, but in general is not suitable--- for complex protocols. Instead use the 'Put' and 'Get' primitives--- directly.------ Instances of Binary should satisfy the following property:------ > decode . encode == id------ That is, the 'get' and 'put' methods should be the inverse of each--- other. A range of instances are provided for basic Haskell types.----class Binary t where-    -- | Encode a value in the Put monad.-    put :: t -> Put-    -- | Decode a value in the Get monad-    get :: Get t--    default put :: (Generic t, GBinary (Rep t)) => t -> Put-    put = gput . from--    default get :: (Generic t, GBinary (Rep t)) => Get t-    get = to `fmap` gget----------------------------------------------------------------------------- Simple instances---- The () type need never be written to disk: values of singleton type--- can be reconstructed from the type alone-instance Binary () where-    put ()  = return ()-    get     = return ()---- Bools are encoded as a byte in the range 0 .. 1-instance Binary Bool where-    put     = putWord8 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8---- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2-instance Binary Ordering where-    put     = putWord8 . fromIntegral . fromEnum-    get     = liftM (toEnum . fromIntegral) getWord8----------------------------------------------------------------------------- Words and Ints---- Words8s are written as bytes-instance Binary Word8 where-    put     = putWord8-    get     = getWord8---- Words16s are written as 2 bytes in big-endian (network) order-instance Binary Word16 where-    put     = putWord16be-    get     = getWord16be---- Words32s are written as 4 bytes in big-endian (network) order-instance Binary Word32 where-    put     = putWord32be-    get     = getWord32be---- Words64s are written as 8 bytes in big-endian (network) order-instance Binary Word64 where-    put     = putWord64be-    get     = getWord64be---- Int8s are written as a single byte.-instance Binary Int8 where-    put i   = put (fromIntegral i :: Word8)-    get     = liftM fromIntegral (get :: Get Word8)---- Int16s are written as a 2 bytes in big endian format-instance Binary Int16 where-    put i   = put (fromIntegral i :: Word16)-    get     = liftM fromIntegral (get :: Get Word16)---- Int32s are written as a 4 bytes in big endian format-instance Binary Int32 where-    put i   = put (fromIntegral i :: Word32)-    get     = liftM fromIntegral (get :: Get Word32)---- Int64s are written as a 4 bytes in big endian format-instance Binary Int64 where-    put i   = put (fromIntegral i :: Word64)-    get     = liftM fromIntegral (get :: Get Word64)------------------------------------------------------------------------------ Words are are written as Word64s, that is, 8 bytes in big endian format-instance Binary Word where-    put i   = put (fromIntegral i :: Word64)-    get     = liftM fromIntegral (get :: Get Word64)---- Ints are are written as Int64s, that is, 8 bytes in big endian format-instance Binary Int where-    put i   = put (fromIntegral i :: Int64)-    get     = liftM fromIntegral (get :: Get Int64)-------------------------------------------------------------------------------- Portable, and pretty efficient, serialisation of Integer------- Fixed-size type for a subset of Integer-type SmallInt = Int32---- Integers are encoded in two ways: if they fit inside a SmallInt,--- they're written as a byte tag, and that value.  If the Integer value--- is too large to fit in a SmallInt, it is written as a byte array,--- along with a sign and length field.--instance Binary Integer where--    {-# INLINE put #-}-    put n | n >= lo && n <= hi = do-        putWord8 0-        put (fromIntegral n :: SmallInt)  -- fast path-     where-        lo = fromIntegral (minBound :: SmallInt) :: Integer-        hi = fromIntegral (maxBound :: SmallInt) :: Integer--    put n = do-        putWord8 1-        put sign-        put (unroll (abs n))         -- unroll the bytes-     where-        sign = fromIntegral (signum n) :: Word8--    {-# INLINE get #-}-    get = do-        tag <- get :: Get Word8-        case tag of-            0 -> liftM fromIntegral (get :: Get SmallInt)-            _ -> do sign  <- get-                    bytes <- get-                    let v = roll bytes-                    return $! if sign == (1 :: Word8) then v else - v------- Fold and unfold an Integer to and from a list of its bytes----unroll :: Integer -> [Word8]-unroll = unfoldr step-  where-    step 0 = Nothing-    step i = Just (fromIntegral i, i `shiftR` 8)--roll :: [Word8] -> Integer-roll   = foldr unstep 0-  where-    unstep b a = a `shiftL` 8 .|. fromIntegral b--{-------- An efficient, raw serialisation for Integer (GHC only)------- TODO  This instance is not architecture portable.  GMP stores numbers as--- arrays of machine sized words, so the byte format is not portable across--- architectures with different endianness and word size.--import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)-import GHC.Base     hiding (ord, chr)-import GHC.Prim-import GHC.Ptr (Ptr(..))-import GHC.IOBase (IO(..))--instance Binary Integer where-    put (S# i)    = putWord8 0 >> put (I# i)-    put (J# s ba) = do-        putWord8 1-        put (I# s)-        put (BA ba)--    get = do-        b <- getWord8-        case b of-            0 -> do (I# i#) <- get-                    return (S# i#)-            _ -> do (I# s#) <- get-                    (BA a#) <- get-                    return (J# s# a#)--instance Binary ByteArray where--    -- Pretty safe.-    put (BA ba) =-        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*-            addr = byteArrayContents# ba-            bs   = unsafePackAddress (I# sz) addr-        in put bs   -- write as a ByteString. easy, yay!--    -- Pretty scary. Should be quick though-    get = do-        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString-        assert (off == 0) $ return $ unsafePerformIO $ do-            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#-            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?-            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)-            freezeByteArray arr---- wrapper for ByteArray#-data ByteArray = BA  {-# UNPACK #-} !ByteArray#-data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)--newByteArray :: Int# -> IO MBA-newByteArray sz = IO $ \s ->-  case newPinnedByteArray# sz s of { (# s', arr #) ->-  (# s', MBA arr #) }--freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray-freezeByteArray arr = IO $ \s ->-  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->-  (# s', BA arr' #) }---}--instance (Binary a,Integral a) => Binary (R.Ratio a) where-    put r = put (R.numerator r) >> put (R.denominator r)-    get = liftM2 (R.%) get get------------------------------------------------------------------------------ Char is serialised as UTF-8-instance Binary Char where-    put a | c <= 0x7f     = put (fromIntegral c :: Word8)-          | c <= 0x7ff    = do put (0xc0 .|. y)-                               put (0x80 .|. z)-          | c <= 0xffff   = do put (0xe0 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | c <= 0x10ffff = do put (0xf0 .|. w)-                               put (0x80 .|. x)-                               put (0x80 .|. y)-                               put (0x80 .|. z)-          | otherwise     = error "Not a valid Unicode code point"-     where-        c = ord a-        z, y, x, w :: Word8-        z = fromIntegral (c           .&. 0x3f)-        y = fromIntegral (shiftR c 6  .&. 0x3f)-        x = fromIntegral (shiftR c 12 .&. 0x3f)-        w = fromIntegral (shiftR c 18 .&. 0x7)--    get = do-        let getByte = liftM (fromIntegral :: Word8 -> Int) get-            shiftL6 = flip shiftL 6 :: Int -> Int-        w <- getByte-        r <- case () of-                _ | w < 0x80  -> return w-                  | w < 0xe0  -> do-                                    x <- liftM (xor 0x80) getByte-                                    return (x .|. shiftL6 (xor 0xc0 w))-                  | w < 0xf0  -> do-                                    x <- liftM (xor 0x80) getByte-                                    y <- liftM (xor 0x80) getByte-                                    return (y .|. shiftL6 (x .|. shiftL6-                                            (xor 0xe0 w)))-                  | otherwise -> do-                                x <- liftM (xor 0x80) getByte-                                y <- liftM (xor 0x80) getByte-                                z <- liftM (xor 0x80) getByte-                                return (z .|. shiftL6 (y .|. shiftL6-                                        (x .|. shiftL6 (xor 0xf0 w))))-        return $! chr r----------------------------------------------------------------------------- Instances for the first few tuples--instance (Binary a, Binary b) => Binary (a,b) where-    put (a,b)           = put a >> put b-    get                 = liftM2 (,) get get--instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where-    put (a,b,c)         = put a >> put b >> put c-    get                 = liftM3 (,,) get get get--instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where-    put (a,b,c,d)       = put a >> put b >> put c >> put d-    get                 = liftM4 (,,,) get get get get--instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where-    put (a,b,c,d,e)     = put a >> put b >> put c >> put d >> put e-    get                 = liftM5 (,,,,) get get get get get------- and now just recurse:-----instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)-        => Binary (a,b,c,d,e,f) where-    put (a,b,c,d,e,f)   = put (a,(b,c,d,e,f))-    get                 = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f)--instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)-        => Binary (a,b,c,d,e,f,g) where-    put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g))-    get                 = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h)-        => Binary (a,b,c,d,e,f,g,h) where-    put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h))-    get                   = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i)-        => Binary (a,b,c,d,e,f,g,h,i) where-    put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i))-    get                     = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i)--instance (Binary a, Binary b, Binary c, Binary d, Binary e,-          Binary f, Binary g, Binary h, Binary i, Binary j)-        => Binary (a,b,c,d,e,f,g,h,i,j) where-    put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j))-    get                       = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j)----------------------------------------------------------------------------- Container types--instance Binary a => Binary [a] where-    put l  = put (length l) >> mapM_ put l-    get    = do n <- get :: Get Int-                getMany n---- | 'getMany n' get 'n' elements in order, without blowing the stack.-getMany :: Binary a => Int -> Get [a]-getMany n = go [] n- where-    go xs 0 = return $! reverse xs-    go xs i = do x <- get-                 -- we must seq x to avoid stack overflows due to laziness in-                 -- (>>=)-                 x `seq` go (x:xs) (i-1)-{-# INLINE getMany #-}--instance (Binary a) => Binary (Maybe a) where-    put Nothing  = putWord8 0-    put (Just x) = putWord8 1 >> put x-    get = do-        w <- getWord8-        case w of-            0 -> return Nothing-            _ -> liftM Just get--instance (Binary a, Binary b) => Binary (Either a b) where-    put (Left  a) = putWord8 0 >> put a-    put (Right b) = putWord8 1 >> put b-    get = do-        w <- getWord8-        case w of-            0 -> liftM Left  get-            _ -> liftM Right get----------------------------------------------------------------------------- ByteStrings (have specially efficient instances)--instance Binary B.ByteString where-    put bs = do put (B.length bs)-                putByteString bs-    get    = get >>= getByteString------- Using old versions of fps, this is a type synonym, and non portable------ Requires 'flexible instances'----instance Binary ByteString where-    put bs = do put (fromIntegral (L.length bs) :: Int)-                putLazyByteString bs-    get    = get >>= getLazyByteString----------------------------------------------------------------------------- Maps and Sets--instance (Binary a) => Binary (Set.Set a) where-    put s = put (Set.size s) >> mapM_ put (Set.toAscList s)-    get   = liftM Set.fromDistinctAscList get--instance (Binary k, Binary e) => Binary (Map.Map k e) where-    put m = put (Map.size m) >> mapM_ put (Map.toAscList m)-    get   = liftM Map.fromDistinctAscList get--instance Binary IntSet.IntSet where-    put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s)-    get   = liftM IntSet.fromDistinctAscList get--instance (Binary e) => Binary (IntMap.IntMap e) where-    put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m)-    get   = liftM IntMap.fromDistinctAscList get----------------------------------------------------------------------------- Queues and Sequences--#if __GLASGOW_HASKELL__ >= 606------ This is valid Hugs, but you need the most recent Hugs-----instance (Binary e) => Binary (Seq.Seq e) where-    put s = put (Seq.length s) >> Fold.mapM_ put s-    get = do n <- get :: Get Int-             rep Seq.empty n get-      where rep xs 0 _ = return $! xs-            rep xs n g = xs `seq` n `seq` do-                           x <- g-                           rep (xs Seq.|> x) (n-1) g--#endif----------------------------------------------------------------------------- Floating point--instance Binary Double where-    put d = put (decodeFloat d)-    get   = liftM2 encodeFloat get get--instance Binary Float where-    put f = put (decodeFloat f)-    get   = liftM2 encodeFloat get get----------------------------------------------------------------------------- Trees--instance (Binary e) => Binary (T.Tree e) where-    put (T.Node r s) = put r >> put s-    get = liftM2 T.Node get get----------------------------------------------------------------------------- Arrays--instance (Binary i, Ix i, Binary e) => Binary (Array i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- write the length-        mapM_ put (elems a)        -- now the elems.-    get = do-        bs <- get-        n  <- get                  -- read the length-        xs <- getMany n            -- now the elems.-        return (listArray bs xs)------- The IArray UArray e constraint is non portable. Requires flexible instances----instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where-    put a = do-        put (bounds a)-        put (rangeSize $ bounds a) -- now write the length-        mapM_ put (elems a)-    get = do-        bs <- get-        n  <- get-        xs <- getMany n-        return (listArray bs xs)
− Distribution/Compat/Binary/Generic.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,-    ScopedTypeVariables, Trustworthy, TypeOperators, TypeSynonymInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---------------------------------------------------------------------------------- |--- Module      : Distribution.Compat.Binary.Generic--- Copyright   : Bryan O'Sullivan--- License     : BSD3-style (see LICENSE)------ Maintainer  : Bryan O'Sullivan <bos@serpentine.com>--- Stability   : unstable--- Portability : Only works with GHC 7.2 and newer------ Instances for supporting GHC generics.----------------------------------------------------------------------------------module Distribution.Compat.Binary.Generic-    (-    ) where--import Control.Applicative-import Distribution.Compat.Binary.Class-import Data.Binary.Get-import Data.Binary.Put-import Data.Bits-import Data.Word-import GHC.Generics---- Type without constructors-instance GBinary V1 where-    gput _ = return ()-    gget   = return undefined---- Constructor without arguments-instance GBinary U1 where-    gput U1 = return ()-    gget    = return U1---- Product: constructor with parameters-instance (GBinary a, GBinary b) => GBinary (a :*: b) where-    gput (x :*: y) = gput x >> gput y-    gget = (:*:) <$> gget <*> gget---- Metadata (constructor name, etc)-instance GBinary a => GBinary (M1 i c a) where-    gput = gput . unM1-    gget = M1 <$> gget---- Constants, additional parameters, and rank-1 recursion-instance Binary a => GBinary (K1 i a) where-    gput = put . unK1-    gget = K1 <$> get---- Borrowed from the cereal package.---- The following GBinary instance for sums has support for serializing--- types with up to 2^64-1 constructors. It will use the minimal--- number of bytes needed to encode the constructor. For example when--- a type has 2^8 constructors or less it will use a single byte to--- encode the constructor. If it has 2^16 constructors or less it will--- use two bytes, and so on till 2^64-1.--#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)-#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)-#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)--instance ( GSum     a, GSum     b-         , GBinary a, GBinary b-         , SumSize    a, SumSize    b) => GBinary (a :+: b) where-    gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)-         | otherwise = sizeError "encode" size-      where-        size = unTagged (sumSize :: Tagged (a :+: b) Word64)--    gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)-         | otherwise = sizeError "decode" size-      where-        size = unTagged (sumSize :: Tagged (a :+: b) Word64)--sizeError :: Show size => String -> size -> error-sizeError s size =-    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"----------------------------------------------------------------------------checkGetSum :: (Ord word, Num word, Bits word, GSum f)-            => word -> word -> Get (f a)-checkGetSum size code | code < size = getSum code size-                      | otherwise   = fail "Unknown encoding for constructor"-{-# INLINE checkGetSum #-}--class GSum f where-    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)-    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put--instance (GSum a, GSum b, GBinary a, GBinary b) => GSum (a :+: b) where-    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL-                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR-        where-          sizeL = size `shiftR` 1-          sizeR = size - sizeL--    putSum !code !size s = case s of-                             L1 x -> putSum code           sizeL x-                             R1 x -> putSum (code + sizeL) sizeR x-        where-          sizeL = size `shiftR` 1-          sizeR = size - sizeL--instance GBinary a => GSum (C1 c a) where-    getSum _ _ = gget--    putSum !code _ x = put code *> gput x----------------------------------------------------------------------------class SumSize f where-    sumSize :: Tagged f Word64--newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}--instance (SumSize a, SumSize b) => SumSize (a :+: b) where-    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) +-                       unTagged (sumSize :: Tagged b Word64)--instance SumSize (C1 c a) where-    sumSize = Tagged 1
− Distribution/Compat/CopyFile.hs 
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.CopyFile (-  copyFile,-  copyFileChanged,-  filesEqual,-  copyOrdinaryFile,-  copyExecutableFile,-  setFileOrdinary,-  setFileExecutable,-  setDirOrdinary,-  ) where---import Control.Monad-         ( when, unless )-import Control.Exception-         ( bracket, bracketOnError, throwIO )-import qualified Data.ByteString.Lazy as BSL-import Distribution.Compat.Exception-         ( catchIO )-import System.IO.Error-         ( ioeSetLocation )-import System.Directory-         ( doesFileExist, renameFile, removeFile )-import Distribution.Compat.TempFile-         ( openBinaryTempFile )-import System.FilePath-         ( takeDirectory )-import System.IO-         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf-         , withBinaryFile )-import Foreign-         ( allocaBytes )--#ifndef mingw32_HOST_OS-import System.Posix.Internals (withFilePath)-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-import Foreign.C-         ( throwErrnoPathIfMinus1_ )-#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 =-  withFilePath name $ \s -> do-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#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 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---- | 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.-filesEqual :: FilePath -> FilePath -> IO Bool-filesEqual f1 f2 = do-  ex1 <- doesFileExist f1-  ex2 <- doesFileExist f2-  if not (ex1 && ex2) then return False else do--    withBinaryFile f1 ReadMode $ \h1 ->-      withBinaryFile f2 ReadMode $ \h2 -> do-        c1 <- BSL.hGetContents h1-        c2 <- BSL.hGetContents h2-        return $! c1 == c2
− Distribution/Compat/CreatePipe.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-module Distribution.Compat.CreatePipe (createPipe) where--import System.IO (Handle, hSetEncoding, localeEncoding)---- The mingw32_HOST_OS CPP macro is GHC-specific-#if mingw32_HOST_OS-import Control.Exception (onException)-import Foreign.C.Error (throwErrnoIfMinus1_)-import Foreign.C.Types (CInt(..), CUInt(..))-import Foreign.Ptr (Ptr)-import Foreign.Marshal.Array (allocaArray)-import Foreign.Storable (peek, peekElemOff)-import GHC.IO.FD (mkFD)-import GHC.IO.Device (IODeviceType(Stream))-import GHC.IO.Handle.FD (mkHandleFromFD)-import System.IO (IOMode(ReadMode, WriteMode))-#elif ghcjs_HOST_OS-#else-import System.Posix.IO (fdToHandle)-import qualified System.Posix.IO as Posix-#endif--createPipe :: IO (Handle, Handle)--- The mingw32_HOST_OS CPP macro is GHC-specific-#if mingw32_HOST_OS-createPipe = do-    (readfd, writefd) <- allocaArray 2 $ \ pfds -> do-        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768)-        readfd <- peek pfds-        writefd <- peekElemOff pfds 1-        return (readfd, writefd)-    (do readh <- fdToHandle readfd ReadMode-        writeh <- fdToHandle writefd WriteMode-        hSetEncoding readh localeEncoding-        hSetEncoding writeh localeEncoding-        return (readh, writeh)) `onException` (close readfd >> close writefd)-  where-    fdToHandle :: CInt -> IOMode -> IO Handle-    fdToHandle fd mode = do-        (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False-        mkHandleFromFD fd' deviceType "" mode False Nothing--    close :: CInt -> IO ()-    close = throwErrnoIfMinus1_ "_close" . c__close--foreign import ccall "io.h _pipe" c__pipe ::-    Ptr CInt -> CUInt -> CInt -> IO CInt--foreign import ccall "io.h _close" c__close ::-    CInt -> IO CInt-#elif ghcjs_HOST_OS-createPipe = error "createPipe"-#else-createPipe = do-    (readfd, writefd) <- Posix.createPipe-    readh <- fdToHandle readfd-    writeh <- fdToHandle writefd-    hSetEncoding readh localeEncoding-    hSetEncoding writeh localeEncoding-    return (readh, writeh)-#endif
− Distribution/Compat/Environment.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}--module Distribution.Compat.Environment (getEnvironment)-       where--import qualified System.Environment as System--#ifdef mingw32_HOST_OS-import qualified Data.Char as Char (toUpper)-#endif--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 Char.toUpper var, val)-#else-getEnvironment = System.getEnvironment-#endif
− Distribution/Compat/Exception.hs 
@@ -1,17 +0,0 @@-module Distribution.Compat.Exception (-  catchIO,-  catchExit,-  tryIO,-  ) where--import System.Exit-import qualified Control.Exception as Exception--tryIO :: IO a -> IO (Either Exception.IOException a)-tryIO = Exception.try--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-catchIO = Exception.catch--catchExit :: IO a -> (ExitCode -> IO a) -> IO a-catchExit = Exception.catch
− Distribution/Compat/ReadP.hs 
@@ -1,398 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- 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://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.19.9217>).------ This version of ReadP has been locally hacked to make it H98, by--- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>------ The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by--- Mark Lentczner <mailto:mark@glyphic.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-  )- where--import Control.Monad( MonadPlus(..), liftM, liftM2, ap )-import Data.Char (isSpace)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Applicative (Alternative(empty, (<|>)))--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 Functor (P s) where-  fmap = liftM--instance Applicative (P s) where-  pure = return-  (<*>) = ap--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 Alternative (P s) where-      empty = mzero-      (<|>) = mplus--instance MonadPlus (P s) where-  mzero = Fail--  -- most common case: two gets are combined-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)--  -- 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 Applicative (Parser r s) where-  pure = return-  (<*>) = ap--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']))
− Distribution/Compat/TempFile.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_HADDOCK hide #-}-module Distribution.Compat.TempFile (-  openTempFile,-  openBinaryTempFile,-  openNewBinaryFile,-  createTempDirectory,-  ) where---import System.FilePath        ((</>))-import Foreign.C              (eEXIST)--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)-import System.Posix.Internals (withFilePath)-import Foreign.C              (CInt)-import GHC.IO.Handle.FD       (fdToHandle)-import Distribution.Compat.Exception (tryIO)-import Control.Exception      (onException)-import Foreign.C              (getErrno, errnoToIOError)--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---- --------------------------------------------------------------- * 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--- TODO: This file should probably be removed.---- 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 file path in the hierarchy here.-    (prefix,suffix) =-       case break (== '.') $ reverse template of-         -- First case: template contains no '.'s. Just re-reverse it.-         (rev_suffix, "")       -> (reverse rev_suffix, "")-         -- Second case: template contains at least one '.'. Strip the-         -- dot from the prefix and prepend it to the suffix (if we don't-         -- do this, the unique number will get added after the '.' and-         -- thus be part of the extension, which is wrong.)-         (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)-         -- Otherwise, something is wrong, because (break (== '.')) should-         -- always return a pair with either the empty string or a string-         -- beginning with '.' as the second component.-         _                      -> error "bug in System.IO.openTempFile"--    oflags = rw_flags .|. o_EXCL .|. o_BINARY--    findTempName x = do-      fd <- withFilePath filepath $ \ f ->-              c_open f oflags 0o666-      if fd < 0-       then do-         errno <- getErrno-         if errno == eEXIST-           then findTempName (x+1)-           else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))-       else do-         -- TODO: We want to tell fdToHandle what the file path is,-         -- as any exceptions etc will only be able to report the-         -- FD currently-         h <- fdToHandle fd `onException` c_close fd-         return (filepath, h)-      where-        filename        = prefix ++ show x ++ suffix-        filepath        = dir `combine` filename--        -- FIXME: bits copied from System.FilePath-        combine a b-                  | null b = a-                  | null a = b-                  | last a == pathSeparator = a ++ b-                  | otherwise = a ++ [pathSeparator] ++ b---- FIXME: Should use System.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--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 ()-#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)-mkPrivateDir s = createDirectory s-#else-mkPrivateDir s = System.Posix.createDirectory s 0o700-#endif
− Distribution/Compiler.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Compiler--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This has an enumeration of the various compilers that Cabal knows about. It--- also specifies the default compiler. Sadly you'll often see code that does--- case analysis on this compiler flavour enumeration like:------ > case compilerFlavor comp of--- >   GHC -> GHC.getInstalledPackages verbosity packageDb 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 #57.--module Distribution.Compiler (-  -- * Compiler flavor-  CompilerFlavor(..),-  buildCompilerId,-  buildCompilerFlavor,-  defaultCompilerFlavor,-  parseCompilerFlavorCompat,--  -- * Compiler id-  CompilerId(..),--  -- * Compiler info-  CompilerInfo(..),-  unknownCompilerInfo,-  AbiTag(..), abiTagString-  ) where--import Distribution.Compat.Binary (Binary)-import Data.Data (Data)-import Data.Typeable (Typeable)-import Data.Maybe (fromMaybe)-import Distribution.Version (Version(..))-import GHC.Generics (Generic)--import Language.Haskell.Extension (Language, Extension)--import qualified System.Info (compilerName, compilerVersion)-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 | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC-                    | HaskellSuite String -- string is the id of the actual compiler-                    | OtherCompiler String-  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)--instance Binary CompilerFlavor--knownCompilerFlavors :: [CompilerFlavor]-knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]--instance Text CompilerFlavor where-  disp (OtherCompiler name) = Disp.text name-  disp (HaskellSuite 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 =-  fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap-  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--buildCompilerVersion :: Version-buildCompilerVersion = System.Info.compilerVersion--buildCompilerId :: CompilerId-buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion---- | The default compiler flavour to pick when compiling stuff. This defaults--- to the compiler used to build the Cabal lib.------ However if it's not a recognised compiler then it's 'Nothing' and the user--- will have to specify which compiler they want.----defaultCompilerFlavor :: Maybe CompilerFlavor-defaultCompilerFlavor = case buildCompilerFlavor of-  OtherCompiler _ -> Nothing-  _               -> Just buildCompilerFlavor---- --------------------------------------------------------------- * Compiler Id--- --------------------------------------------------------------data CompilerId = CompilerId CompilerFlavor Version-  deriving (Eq, Generic, Ord, Read, Show)--instance Binary CompilerId--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---- --------------------------------------------------------------- * Compiler Info--- ---------------------------------------------------------------- | Compiler information used for resolving configurations. Some fields can be---   set to Nothing to indicate that the information is unknown.--data CompilerInfo = CompilerInfo {-         compilerInfoId         :: CompilerId,-         -- ^ Compiler flavour and version.-         compilerInfoAbiTag     :: AbiTag,-         -- ^ Tag for distinguishing incompatible ABI's on the same architecture/os.-         compilerInfoCompat     :: Maybe [CompilerId],-         -- ^ Other implementations that this compiler claims to be compatible with, if known.-         compilerInfoLanguages  :: Maybe [Language],-         -- ^ Supported language standards, if known.-         compilerInfoExtensions :: Maybe [Extension]-         -- ^ Supported extensions, if known.-     }-     deriving (Generic, Show, Read)--instance Binary CompilerInfo--data AbiTag-  = NoAbiTag-  | AbiTag String-  deriving (Generic, Show, Read)--instance Binary AbiTag--instance Text AbiTag where-  disp NoAbiTag     = Disp.empty-  disp (AbiTag tag) = Disp.text tag--  parse = do-    tag <- Parse.munch (\c -> Char.isAlphaNum c || c == '_')-    if null tag then return NoAbiTag else return (AbiTag tag)--abiTagString :: AbiTag -> String-abiTagString NoAbiTag     = ""-abiTagString (AbiTag tag) = tag---- | Make a CompilerInfo of which only the known information is its CompilerId,---   its AbiTag and that it does not claim to be compatible with other---   compiler id's.-unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo-unknownCompilerInfo compilerId abiTag =-  CompilerInfo compilerId abiTag (Just []) Nothing Nothing
− 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!-:-)--}--{-# OPTIONS_HADDOCK hide #-}-module Distribution.GetOpt (-   -- * GetOpt-   getOpt, getOpt',-   usageInfo,-   ArgOrder(..),-   OptDescr(..),-   ArgDescr(..),--   -- * Example--   -- $example-) where--import Data.List ( isPrefixOf, intercalate, find )-import Data.Maybe ( isJust )---- |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 [ (intercalate ", " (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 ' ')--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-                          , isJust (find (p opt) xs)]-         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,391 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.InstalledPackageInfo--- Copyright   :  (c) The University of Glasgow 2004------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ This is the information about an /installed/ package that--- is communicated to the @ghc-pkg@ program in order to register--- a package.  @ghc-pkg@ now consumes this package format (as of version--- 6.4). This is specific to GHC at the moment.------ The @.cabal@ file format is for describing a package that is not yet--- installed. It has a lot of flexibility, like conditionals and dependency--- ranges. As such, that format is not at all suitable for describing a package--- that has already been built and installed. By the time we get to that stage,--- we have resolved all conditionals and resolved dependency version--- constraints to exact versions of dependent packages. So, this module defines--- the 'InstalledPackageInfo' data structure that contains all the info we keep--- about an installed package. There is a parser and pretty printer. The--- textual format is rather simpler than the @.cabal@ format: there are no--- sections, for example.---- This module is meant to be local-only to Distribution...--module Distribution.InstalledPackageInfo (-        InstalledPackageInfo_(..), InstalledPackageInfo,-        OriginalModule(..), ExposedModule(..),-        ParseResult(..), PError(..), PWarning,-        emptyInstalledPackageInfo,-        parseInstalledPackageInfo,-        showInstalledPackageInfo,-        showInstalledPackageInfoField,-        showSimpleInstalledPackageInfoField,-        fieldsInstalledPackageInfo,-  ) where--import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), PError(..), PWarning-         , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, showSimpleSingleNamedField-         , parseFieldsFlat-         , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ-         , showFilePath, showToken, boolField, parseOptVersion-         , parseFreeText, showFreeText, parseOptCommaList )-import Distribution.License     ( License(..) )-import Distribution.Package-         ( PackageName(..), PackageIdentifier(..)-         , PackageId, InstalledPackageId(..)-         , packageName, packageVersion, PackageKey(..) )-import qualified Distribution.Package as Package-import Distribution.ModuleName-         ( ModuleName )-import Distribution.Version-         ( Version(..) )-import Distribution.Text-         ( Text(disp, parse) )-import Text.PrettyPrint as Disp-import qualified Distribution.Compat.ReadP as Parse--import Distribution.Compat.Binary  (Binary)-import Data.Maybe   (fromMaybe)-import GHC.Generics (Generic)---- -------------------------------------------------------------------------------- The InstalledPackageInfo type---data InstalledPackageInfo_ m-   = InstalledPackageInfo {-        -- these parts are exactly the same as PackageDescription-        installedPackageId :: InstalledPackageId,-        sourcePackageId    :: PackageId,-        packageKey         :: PackageKey,-        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    :: [ExposedModule],-        instantiatedWith  :: [(m, OriginalModule)],-        hiddenModules     :: [m],-        trusted           :: Bool,-        importDirs        :: [FilePath],-        libraryDirs       :: [FilePath],-        dataDir           :: FilePath,-        hsLibraries       :: [String],-        extraLibraries    :: [String],-        extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi-        includeDirs       :: [FilePath],-        includes          :: [String],-        depends           :: [InstalledPackageId],-        ccOptions         :: [String],-        ldOptions         :: [String],-        frameworkDirs     :: [FilePath],-        frameworks        :: [String],-        haddockInterfaces :: [FilePath],-        haddockHTMLs      :: [FilePath],-        pkgRoot           :: Maybe FilePath-    }-    deriving (Generic, Read, Show)--instance Binary m => Binary (InstalledPackageInfo_ m)--instance Package.Package          (InstalledPackageInfo_ str) where-   packageId = sourcePackageId--instance Package.PackageInstalled (InstalledPackageInfo_ str) where-   installedPackageId = installedPackageId-   installedDepends = depends--type InstalledPackageInfo = InstalledPackageInfo_ ModuleName--emptyInstalledPackageInfo :: InstalledPackageInfo_ m-emptyInstalledPackageInfo-   = InstalledPackageInfo {-        installedPackageId = InstalledPackageId "",-        sourcePackageId    = PackageIdentifier (PackageName "") noVersion,-        packageKey         = OldPackageKey (PackageIdentifier-                                               (PackageName "") noVersion),-        license           = UnspecifiedLicense,-        copyright         = "",-        maintainer        = "",-        author            = "",-        stability         = "",-        homepage          = "",-        pkgUrl            = "",-        synopsis          = "",-        description       = "",-        category          = "",-        exposed           = False,-        exposedModules    = [],-        hiddenModules     = [],-        instantiatedWith  = [],-        trusted           = False,-        importDirs        = [],-        libraryDirs       = [],-        dataDir           = "",-        hsLibraries       = [],-        extraLibraries    = [],-        extraGHCiLibraries= [],-        includeDirs       = [],-        includes          = [],-        depends           = [],-        ccOptions         = [],-        ldOptions         = [],-        frameworkDirs     = [],-        frameworks        = [],-        haddockInterfaces = [],-        haddockHTMLs      = [],-        pkgRoot           = Nothing-    }--noVersion :: Version-noVersion = Version [] []---- -------------------------------------------------------------------------------- Exposed modules--data OriginalModule-   = OriginalModule {-       originalPackageId :: InstalledPackageId,-       originalModuleName :: ModuleName-     }-  deriving (Generic, Eq, Read, Show)--data ExposedModule-   = ExposedModule {-       exposedName      :: ModuleName,-       exposedReexport  :: Maybe OriginalModule,-       exposedSignature :: Maybe OriginalModule -- This field is unused for now.-     }-  deriving (Generic, Read, Show)--instance Text OriginalModule where-    disp (OriginalModule ipi m) =-        disp ipi <> Disp.char ':' <> disp m-    parse = do-        ipi <- parse-        _ <- Parse.char ':'-        m <- parse-        return (OriginalModule ipi m)--instance Text ExposedModule where-    disp (ExposedModule m reexport signature) =-        Disp.sep [ disp m-                 , case reexport of-                    Just m' -> Disp.sep [Disp.text "from", disp m']-                    Nothing -> Disp.empty-                 , case signature of-                    Just m' -> Disp.sep [Disp.text "is", disp m']-                    Nothing -> Disp.empty-                 ]-    parse = do-        m <- parseModuleNameQ-        Parse.skipSpaces-        reexport <- Parse.option Nothing $ do-            _ <- Parse.string "from"-            Parse.skipSpaces-            fmap Just parse-        Parse.skipSpaces-        signature <- Parse.option Nothing $ do-            _ <- Parse.string "is"-            Parse.skipSpaces-            fmap Just parse-        return (ExposedModule m reexport signature)---instance Binary OriginalModule--instance Binary ExposedModule---- To maintain backwards-compatibility, we accept both comma/non-comma--- separated variants of this field.  You SHOULD use the comma syntax if you--- use any new functions, although actually it's unambiguous due to a quirk--- of the fact that modules must start with capital letters.--showExposedModules :: [ExposedModule] -> Disp.Doc-showExposedModules xs-    | all isExposedModule xs = fsep (map disp xs)-    | otherwise = fsep (Disp.punctuate comma (map disp xs))-    where isExposedModule (ExposedModule _ Nothing Nothing) = True-          isExposedModule _ = False--parseExposedModules :: Parse.ReadP r [ExposedModule]-parseExposedModules = parseOptCommaList parse---- -------------------------------------------------------------------------------- Parsing--parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo-parseInstalledPackageInfo =-    parseFieldsFlat (fieldsInstalledPackageInfo ++ deprecatedFieldDescrs)-    emptyInstalledPackageInfo--parseInstantiatedWith :: Parse.ReadP r (ModuleName, OriginalModule)-parseInstantiatedWith = do k <- parse-                           _ <- Parse.char '='-                           n <- parse-                           _ <- Parse.char '@'-                           p <- parse-                           return (k, OriginalModule p n)---- -------------------------------------------------------------------------------- Pretty-printing--showInstalledPackageInfo :: InstalledPackageInfo -> String-showInstalledPackageInfo = showFields fieldsInstalledPackageInfo--showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo--showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)-showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo--showInstantiatedWith :: (ModuleName, OriginalModule) -> Doc-showInstantiatedWith (k, OriginalModule p m) = disp k <> text "=" <> disp m <> text "@" <> disp p---- -------------------------------------------------------------------------------- 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 "key"-                           disp                   parse-                           packageKey             (\ipid pkg -> pkg{packageKey=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})- , simpleField "exposed-modules"-        showExposedModules parseExposedModules-        exposedModules     (\xs    pkg -> pkg{exposedModules=xs})- , listField   "hidden-modules"-        disp               parseModuleNameQ-        hiddenModules      (\xs    pkg -> pkg{hiddenModules=xs})- , listField   "instantiated-with"-        showInstantiatedWith parseInstantiatedWith-        instantiatedWith   (\xs    pkg -> pkg{instantiatedWith=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})- , simpleField "data-dir"-        showFilePath       (parseFilePathQ Parse.<++ return "")-        dataDir            (\val pkg -> pkg{dataDir=val})- , 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   "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})- , simpleField "pkgroot"-        (const Disp.empty)        parseFilePathQ-        (fromMaybe "" . pkgRoot)  (\xs pkg -> pkg{pkgRoot=Just xs})- ]--deprecatedFieldDescrs :: [FieldDescr InstalledPackageInfo]-deprecatedFieldDescrs = [-   listField   "hugs-options"-        showToken          parseTokenQ-        (const [])        (const id)-  ]
− Distribution/License.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.License--- Description :  The License data type.--- Copyright   :  Isaac Jones 2003-2005---                Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Package descriptions contain fields for specifying the name of a software--- license and the name of the file containing the text of that license. While--- package authors may choose any license they like, Cabal provides an--- enumeration of a small set of common free and open source software licenses.--- This is done so that Hackage can recognise licenses, so that tools can detect--- <https://en.wikipedia.org/wiki/License_compatibility licensing conflicts>,--- and to deter--- <https://en.wikipedia.org/wiki/License_proliferation license proliferation>.------ It is recommended that all package authors use the @license-file@ or--- @license-files@ fields in their package descriptions. Further information--- about these fields can be found in the--- <http://www.haskell.org/cabal/users-guide/developing-packages.html#package-descriptions Cabal users guide>.------ = Additional resources------ The following websites provide information about free and open source--- software licenses:------ * <http://www.opensource.org The Open Source Initiative (OSI)>------ * <https://www.fsf.org The Free Software Foundation (FSF)>------ = Disclaimer------ The descriptions of software licenses provided by this documentation are--- intended for informational purposes only and in no way constitute legal--- advice. Please read the text of the licenses and consult a lawyer for any--- advice regarding software licensing.--module Distribution.License (-    License(..),-    knownLicenses,-  ) 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 Distribution.Compat.Binary (Binary)-import qualified Data.Char as Char (isAlphaNum)-import Data.Data (Data)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)---- | Indicates the license under which a package's source code is released.--- Versions of the licenses not listed here will be rejected by Hackage and--- cause @cabal check@ to issue a warning.-data License =-    -- TODO: * remove BSD4--    -- | GNU General Public License,-    -- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or-    -- <https://www.gnu.org/licenses/gpl.html version 3>.-    GPL (Maybe Version)--    -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.-  | AGPL (Maybe Version)--    -- | GNU Lesser General Public License,-    -- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or-    -- <https://www.gnu.org/licenses/lgpl.html version 3>.-  | LGPL (Maybe Version)--    -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.-  | BSD2--    -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.-  | BSD3--    -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.-    -- This license has not been approved by the OSI and is incompatible with-    -- the GNU GPL. It is provided for historical reasons and should be avoided.-  | BSD4--    -- | <http://www.opensource.org/licenses/MIT MIT license>.-  | MIT--    -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>-  | ISC--    -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.-  | MPL Version--    -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.-  | Apache (Maybe Version)--    -- | The author of a package disclaims any copyright to its source code and-    -- dedicates it to the public domain. This is not a software license. Please-    -- note that it is not possible to dedicate works to the public domain in-    -- every jurisdiction, nor is a work that is in the public domain in one-    -- jurisdiction necessarily in the public domain elsewhere.-  | PublicDomain--    -- | Explicitly 'All Rights Reserved', eg for proprietary software. The-    -- package may not be legally modified or redistributed by anyone but the-    -- rightsholder.-  | AllRightsReserved--    -- | No license specified which legally defaults to 'All Rights Reserved'.-    -- The package may not be legally modified or redistributed by anyone but-    -- the rightsholder.-  | UnspecifiedLicense--    -- | Any other software license.-  | OtherLicense--    -- | Indicates an erroneous license name.-  | UnknownLicense String-  deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary License---- | The list of all currently recognised licenses.-knownLicenses :: [License]-knownLicenses = [ GPL  unversioned, GPL  (version [2]),    GPL  (version [3])-                , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])-                , AGPL unversioned,                        AGPL (version [3])-                , BSD2, BSD3, MIT, ISC-                , MPL (Version [2, 0] [])-                , Apache unversioned, Apache (version [2, 0])-                , 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 (AGPL version)         = Disp.text "AGPL"   <> dispOptVersion version-  disp (MPL  version)         = Disp.text "MPL"    <> dispVersion    version-  disp (Apache version)       = Disp.text "Apache" <> 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-      ("AGPL",              _      ) -> AGPL version-      ("BSD2",              Nothing) -> BSD2-      ("BSD3",              Nothing) -> BSD3-      ("BSD4",              Nothing) -> BSD4-      ("ISC",               Nothing) -> ISC-      ("MIT",               Nothing) -> MIT-      ("MPL",         Just version') -> MPL version'-      ("Apache",            _      ) -> Apache version-      ("PublicDomain",      Nothing) -> PublicDomain-      ("AllRightsReserved", Nothing) -> AllRightsReserved-      ("OtherLicense",      Nothing) -> OtherLicense-      _                              -> UnknownLicense $ name ++-                                        maybe "" (('-':) . display) version--dispOptVersion :: Maybe Version -> Disp.Doc-dispOptVersion Nothing  = Disp.empty-dispOptVersion (Just v) = dispVersion v--dispVersion :: Version -> Disp.Doc-dispVersion v = Disp.char '-' <> disp v
− Distribution/Make.hs 
@@ -1,184 +0,0 @@--------------------------------------------------------------------------------- |--- 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.-----                      copy :---                              $(MAKE) install prefix=$(destdir)/$(prefix) \---                                              bindir=$(destdir)/$(bindir) \--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  (intercalate)-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) commands args of-    CommandHelp   help                 -> printHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->-      case commandParse of-        _ | fromFlag (globalVersion flags)        -> printVersion-          | fromFlag (globalNumericVersion flags) -> printNumericVersion-        CommandHelp     help           -> printHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action--  where-    printHelp help = getProgName >>= putStr . help-    printOptionsList = putStr . unlines-    printErrors errs = do-      putStr (intercalate "\n" errs)-      exitWith (ExitFailure 1)-    printNumericVersion = putStrLn $ 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,110 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.ModuleName--- Copyright   :  Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Data type for Haskell module names.--module Distribution.ModuleName (-        ModuleName,-        fromString,-        components,-        toFilePath,-        main,-        simple,-  ) where--import Distribution.Text-         ( Text(..) )--import Distribution.Compat.Binary (Binary)-import qualified Data.Char as Char-         ( isAlphaNum, isUpper )-import Data.Data (Data)-import Data.Typeable (Typeable)-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-import Data.List-         ( intercalate, intersperse )-import GHC.Generics (Generic)-import System.FilePath-         ( pathSeparator )---- | A valid Haskell module name.----newtype ModuleName = ModuleName [String]-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary ModuleName--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 = intercalate [pathSeparator] . components
− Distribution/Package.hs 
@@ -1,379 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Package--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Defines a package identifier along with a parser and pretty printer for it.--- 'PackageIdentifier's consist of a name and an exact version. It also defines--- a 'Dependency' data type. A dependency is a package name and a version--- range, like @\"foo >= 1.2 && < 2\"@.--module Distribution.Package (-        -- * Package ids-        PackageName(..),-        PackageIdentifier(..),-        PackageId,--        -- * Installed package identifiers-        InstalledPackageId(..),--        -- * Package keys (used for linker symbols and library name)-        PackageKey(..),-        mkPackageKey,-        packageKeyHash,-        packageKeyLibraryName,--        -- * Package source dependencies-        Dependency(..),-        thisPackageVersion,-        notThisPackageVersion,-        simplifyDependency,--        -- * Package classes-        Package(..), packageName, packageVersion,-        PackageFixedDeps(..),-        PackageInstalled(..),-  ) where--import Distribution.ModuleName ( ModuleName )-import Distribution.Version-         ( Version(..), VersionRange, anyVersion, thisVersion-         , notThisVersion, simplifyVersionRange )--import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((<++))-import qualified Text.PrettyPrint as Disp--import Control.DeepSeq (NFData(..))-import Data.Ord ( comparing )-import Distribution.Compat.Binary (Binary)-import qualified Data.Char as Char-    ( isDigit, isAlphaNum, isUpper, isLower, ord, chr )-import Data.Data ( Data )-import Data.List ( intercalate, foldl', sortBy )-import Data.Typeable ( Typeable )-import Data.Word ( Word64 )-import GHC.Fingerprint ( Fingerprint(..), fingerprintString )-import GHC.Generics (Generic)-import Numeric ( showIntAtBase )-import Text.PrettyPrint ((<>), (<+>), text)--newtype PackageName = PackageName { unPackageName :: String }-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary PackageName--instance Text PackageName where-  disp (PackageName n) = Disp.text n-  parse = do-    ns <- Parse.sepBy1 component (Parse.char '-')-    return (PackageName (intercalate "-" 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).--instance NFData PackageName where-    rnf (PackageName pkg) = rnf pkg---- | Type alias so we can use the shorter name PackageId.-type PackageId = PackageIdentifier---- | The name and version of a package.-data PackageIdentifier-    = PackageIdentifier {-        pkgName    :: PackageName, -- ^The name of this package, eg. foo-        pkgVersion :: Version -- ^the version of this package, eg 1.2-     }-     deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary PackageIdentifier--instance 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)--instance NFData PackageIdentifier where-    rnf (PackageIdentifier name version) = rnf name `seq` rnf version---- --------------------------------------------------------------- * 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 (Generic, Read,Show,Eq,Ord,Typeable,Data)--instance Binary InstalledPackageId--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 Keys--- ---------------------------------------------------------------- | A 'PackageKey' is the notion of "package ID" which is visible to the--- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible--- concept written explicity in Cabal files; on the other hand, a 'PackageKey'--- may contain, for example, information about the transitive dependency--- tree of a package.  Why is this not an 'InstalledPackageId'?  A 'PackageKey'--- affects the ABI because it is used for linker symbols; however, an--- 'InstalledPackageId' can be used to distinguish two ABI-compatible versions--- of a library.------ The key is defined to be a 128-bit MD5 hash, separated into two 64-bit--- components (the most significant component coming first) which are--- individually base-62 encoded (A-Z, a-z, 0-9).------ @---      key         ::= hash64 hash64---      hash64      ::= [A-Za-z0-9]{11}--- @------ The string that is hashed is specified as raw_key:------ @---      raw_key     ::= package_id "\n"---                      holes_nl---                      depends_nl---      package_id  ::= package_name "-" package_version---      holes_nl    ::= ""---                    | hole_inst "\n" holes_nl---      hole_inst   ::= modulename " " key ":" modulename---      depends_nl  ::= ""---                    | depend "\n" depends_nl---      depend      ::= key--- @------ The holes list MUST be sorted by the first modulename; the depends list--- MUST be sorted by the key.  holes describes the backing implementations of--- all holes in the package; depends describes all of the build-depends of--- a package.  A package key MAY be used in holes even if it is not--- mentioned in depends: depends contains STRICTLY packages which are--- textually mentioned in the package description.------ The trailing newline is MANDATORY.------ There is also a variant of package key which is prefixed by a informational--- string.  This key MUST NOT be used in the computation of the hash proper,--- but it is useful for human-readable consumption.------ @---      infokey     ::= infostring "_" key---      infostring  ::= [A-Za-z0-9-]+--- @------ For example, Cabal provides a key with the first five characters of the--- package name for linker symbols.----data PackageKey-    -- | Modern package key which is a hash of the PackageId and the transitive-    -- dependency key.  Manually inline it here so we can get the instances-    -- we need.  Also contains a short informative string-    = PackageKey !String {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64-    -- | Old-style package key which is just a 'PackageId'.  Required because-    -- old versions of GHC assume that the 'sourcePackageId' recorded for an-    -- installed package coincides with the package key it was compiled with.-    | OldPackageKey !PackageId-    deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)--instance Binary PackageKey---- | Convenience function which converts a fingerprint into a new-style package--- key.-fingerprintPackageKey :: String -> Fingerprint -> PackageKey-fingerprintPackageKey s (Fingerprint a b) = PackageKey s a b---- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the--- immediate dependencies.-mkPackageKey :: Bool -- are modern style package keys supported?-             -> PackageId-             -> [PackageKey]     -- dependencies-             -> [(ModuleName, (PackageKey, ModuleName))] -- hole instantiations-             -> PackageKey-mkPackageKey True pid deps holes =-    fingerprintPackageKey stubName . fingerprintString $-        display pid ++ "\n" ++-        -- NB: packageKeyHash, NOT display-        concat [ display m ++ " " ++ packageKeyHash p' ++ ":" ++ display m' ++ "\n"-               | (m, (p', m')) <- sortBy (comparing fst) holes] ++-        concat [ packageKeyHash d ++ "\n"-               | d <- sortBy (comparing packageKeyHash) deps]-  where stubName = take 5 (filter (/= '-') (unPackageName (pkgName pid)))-mkPackageKey False pid _ _ = OldPackageKey pid---- The base-62 code is based off of 'locators'--- ((c) Operational Dynamics Consulting, BSD3 licensed)---- Note: Instead of base-62 encoding a single 128-bit integer--- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers--- (2 * ceil(10.75) characters).  Luckily for us, it's the same number of--- characters!  In the long term, this should go in GHC.Fingerprint,--- but not now...---- | Size of a 64-bit word when written as a base-62 string-word64Base62Len :: Int-word64Base62Len = 11---- | Converts a 64-bit word into a base-62 string-toBase62 :: Word64 -> String-toBase62 w = pad ++ str-  where-    pad = replicate len '0'-    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)-    str = showIntAtBase 62 represent w ""-    represent :: Int -> Char-    represent x-        | x < 10 = Char.chr (48 + x)-        | x < 36 = Char.chr (65 + x - 10)-        | x < 62 = Char.chr (97 + x - 36)-        | otherwise = error ("represent (base 62): impossible!")---- | Parses a base-62 string into a 64-bit word-fromBase62 :: String -> Word64-fromBase62 ss = foldl' multiply 0 ss-  where-    value :: Char -> Int-    value c-        | Char.isDigit c = Char.ord c - 48-        | Char.isUpper c = Char.ord c - 65 + 10-        | Char.isLower c = Char.ord c - 97 + 36-        | otherwise = error ("value (base 62): impossible!")--    multiply :: Word64 -> Char -> Word64-    multiply acc c = acc * 62 + (fromIntegral $ value c)---- | Parses a base-62 string into a fingerprint.-readBase62Fingerprint :: String -> Fingerprint-readBase62Fingerprint s = Fingerprint w1 w2- where (s1,s2) = splitAt word64Base62Len s-       w1 = fromBase62 s1-       w2 = fromBase62 (take word64Base62Len s2)--packageKeyHash :: PackageKey -> String-packageKeyHash (PackageKey _ w1 w2) = toBase62 w1 ++ toBase62 w2-packageKeyHash (OldPackageKey pid) = display pid--packageKeyLibraryName :: PackageId -> PackageKey -> String-packageKeyLibraryName pid (PackageKey _ w1 w2) = display pid ++ "-" ++ toBase62 w1 ++ toBase62 w2-packageKeyLibraryName _ (OldPackageKey pid) = display pid--instance Text PackageKey where-  disp (PackageKey prefix w1 w2) = Disp.text prefix <> Disp.char '_'-                        <> Disp.text (toBase62 w1) <> Disp.text (toBase62 w2)-  disp (OldPackageKey pid) = disp pid--  parse = parseNew <++ parseOld-    where parseNew = do-            prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-")-            _ <- Parse.char '_' -- if we use '-' it's ambiguous-            fmap (fingerprintPackageKey prefix . readBase62Fingerprint)-                . Parse.count (word64Base62Len * 2)-                $ Parse.satisfy Char.isAlphaNum-          parseOld = do pid <- parse-                        return (OldPackageKey pid)--instance NFData PackageKey where-    rnf (PackageKey prefix _ _) = rnf prefix-    rnf (OldPackageKey pid) = rnf pid---- --------------------------------------------------------------- * Package source dependencies--- ---------------------------------------------------------------- | Describes a dependency on a source package (API)----data Dependency = Dependency PackageName VersionRange-                  deriving (Generic, Read, Show, Eq, Typeable, Data)--instance Binary Dependency--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]---- | Class of installed packages.------ The primary data type which is an instance of this package is--- 'InstalledPackageInfo', but when we are doing install plans in Cabal install--- we may have other, installed package-like things which contain more metadata.--- Installed packages have exact dependencies 'installedDepends'.-class Package pkg => PackageInstalled pkg where-  installedPackageId :: pkg -> InstalledPackageId-  installedDepends :: pkg -> [InstalledPackageId]
− Distribution/PackageDescription.hs 
@@ -1,1157 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines the data structure for the @.cabal@ file format. There are--- several parts to this structure. It has top level info and then 'Library',--- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have--- associated 'BuildInfo' data that's used to build the library, exe, test, or--- benchmark.  To further complicate things there is both a 'PackageDescription'--- and a 'GenericPackageDescription'. This distinction relates to cabal--- configurations. When we initially read a @.cabal@ file we get a--- 'GenericPackageDescription' which has all the conditional sections.--- Before actually building a package we have to decide--- on each conditional. Once we've done that we get a 'PackageDescription'.--- It was done this way initially to avoid breaking too much stuff when the--- feature was introduced. It could probably do with being rationalised at some--- point to make it simpler.--module Distribution.PackageDescription (-        -- * Package descriptions-        PackageDescription(..),-        emptyPackageDescription,-        specVersion,-        descCabalVersion,-        BuildType(..),-        knownBuildTypes,--        -- ** Renaming-        ModuleRenaming(..),-        defaultRenaming,-        lookupRenaming,--        -- ** Libraries-        Library(..),-        ModuleReexport(..),-        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,-        hcProfOptions,-        hcSharedOptions,--        -- ** Supplementary build information-        HookedBuildInfo,-        emptyHookedBuildInfo,-        updatePackageDescription,--        -- * package configuration-        GenericPackageDescription(..),-        Flag(..), FlagName(..), FlagAssignment,-        CondTree(..), ConfVar(..), Condition(..),--        -- * Source repositories-        SourceRepo(..),-        RepoKind(..),-        RepoType(..),-        knownRepoTypes,-  ) where--import Distribution.Compat.Binary (Binary)-import Data.Data   (Data)-import Data.List   (nub, intercalate)-import Data.Maybe  (fromMaybe, maybeToList)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(mempty, mappend))-#endif-import Data.Typeable ( Typeable )-import Control.Monad (MonadPlus(mplus))-import GHC.Generics (Generic)-import Text.PrettyPrint as Disp-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP ((<++))-import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)-import qualified Data.Map as Map-import Data.Map (Map)--import Distribution.Package-         ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)-         , Dependency, Package(..), PackageName, packageName )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version-         ( Version(Version), VersionRange, anyVersion, orLaterVersion-         , asVersionIntervals, LowerBound(..) )-import Distribution.License  (License(UnspecifiedLicense))-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,-        licenseFiles   :: [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.-        -- | YOU PROBABLY DON'T WANT TO USE THIS FIELD. This field is-        -- special! Depending on how far along processing the-        -- PackageDescription we are, the contents of this field are-        -- either nonsense, or the collected dependencies of *all* the-        -- components in this package.  buildDepends is initialized by-        -- 'finalizePackageDescription' and 'flattenPackageDescription';-        -- prior to that, dependency info is stored in the 'CondTree'-        -- built around a 'GenericPackageDescription'.  When this-        -- resolution is done, dependency info is written to the inner-        -- 'BuildInfo' and this field.  This is all horrible, and #2066-        -- tracks progress to get rid of this field.-        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],-        extraDocFiles  :: [FilePath]-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary PackageDescription--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      = UnspecifiedLicense,-                      licenseFiles = [],-                      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 = [],-                      extraDocFiles = []-                     }---- | 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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildType--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---- ------------------------------------------------------------------------------ Module renaming---- | Renaming applied to the modules provided by a package.--- The boolean indicates whether or not to also include all of the--- original names of modules.  Thus, @ModuleRenaming False []@ is--- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@--- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".----data ModuleRenaming = ModuleRenaming Bool [(ModuleName, ModuleName)]-    deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)--defaultRenaming :: ModuleRenaming-defaultRenaming = ModuleRenaming True []--lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming-lookupRenaming pkg rns =-    Map.findWithDefault-        (error ("lookupRenaming: missing renaming for " ++ display (packageName pkg)))-        (packageName pkg) rns--instance Binary ModuleRenaming where--instance Monoid ModuleRenaming where-    ModuleRenaming b rns `mappend` ModuleRenaming b' rns'-        = ModuleRenaming (b || b') (rns ++ rns') -- ToDo: dedupe?-    mempty = ModuleRenaming False []---- NB: parentheses are mandatory, because later we may extend this syntax--- to allow "hiding (A, B)" or other modifier words.-instance Text ModuleRenaming where-  disp (ModuleRenaming True []) = Disp.empty-  disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns-    where dispRns = Disp.parens-                         (Disp.hsep-                            (Disp.punctuate Disp.comma (map dispEntry vs)))-          dispEntry (orig, new)-            | orig == new = disp orig-            | otherwise = disp orig <+> text "as" <+> disp new--  parse = do Parse.string "with" >> Parse.skipSpaces-             fmap (ModuleRenaming True) parseRns-         <++ fmap (ModuleRenaming False) parseRns-         <++ return (ModuleRenaming True [])-    where parseRns = do-             rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList-             Parse.skipSpaces-             return rns-          parseList =-            Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces)-          parseEntry :: Parse.ReadP r (ModuleName, ModuleName)-          parseEntry = do-            orig <- parse-            Parse.skipSpaces-            (do _ <- Parse.string "as"-                Parse.skipSpaces-                new <- parse-                Parse.skipSpaces-                return (orig, new)-             <++-                return (orig, orig))---- ------------------------------------------------------------------------------ The Library type--data Library = Library {-        exposedModules    :: [ModuleName],-        reexportedModules :: [ModuleReexport],-        requiredSignatures:: [ModuleName], -- ^ What sigs need implementations?-        exposedSignatures:: [ModuleName], -- ^ What sigs are visible to users?-        libExposed        :: Bool, -- ^ Is the lib to be exposed by default?-        libBuildInfo      :: BuildInfo-    }-    deriving (Generic, Show, Eq, Read, Typeable, Data)--instance Binary Library--instance Monoid Library where-  mempty = Library {-    exposedModules = mempty,-    reexportedModules = mempty,-    requiredSignatures = mempty,-    exposedSignatures = mempty,-    libExposed     = True,-    libBuildInfo   = mempty-  }-  mappend a b = Library {-    exposedModules = combine exposedModules,-    reexportedModules = combine reexportedModules,-    requiredSignatures = combine requiredSignatures,-    exposedSignatures = combine exposedSignatures,-    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)--- which need to be compiled.  (This does not include reexports, which--- do not need to be compiled.)-libModules :: Library -> [ModuleName]-libModules lib = exposedModules lib-              ++ otherModules (libBuildInfo lib)-              ++ exposedSignatures lib-              ++ requiredSignatures lib---- -------------------------------------------------------------------------------- Module re-exports--data ModuleReexport = ModuleReexport {-       moduleReexportOriginalPackage :: Maybe PackageName,-       moduleReexportOriginalName    :: ModuleName,-       moduleReexportName            :: ModuleName-    }-    deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary ModuleReexport--instance Text ModuleReexport where-    disp (ModuleReexport mpkgname origname newname) =-          maybe Disp.empty (\pkgname -> disp pkgname <> Disp.char ':') mpkgname-       <> disp origname-      <+> if newname == origname-            then Disp.empty-            else Disp.text "as" <+> disp newname--    parse = do-      mpkgname <- Parse.option Nothing $ do-                    pkgname <- parse -                    _       <- Parse.char ':'-                    return (Just pkgname)-      origname <- parse-      newname  <- Parse.option origname $ do-                    Parse.skipSpaces-                    _ <- Parse.string "as"-                    Parse.skipSpaces-                    parse-      return (ModuleReexport mpkgname origname newname)---- ------------------------------------------------------------------------------ The Executable type--data Executable = Executable {-        exeName    :: String,-        modulePath :: FilePath,-        buildInfo  :: BuildInfo-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Executable--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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary TestSuite---- | The test suite interfaces that are currently defined. Each test suite must--- specify which interface it supports.------ More interfaces may be defined in future, either new revisions or totally--- new interfaces.----data TestSuiteInterface =--     -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form-     -- of an executable. It returns a zero exit code for success, non-zero for-     -- failure. The stdout and stderr channels may be logged. It takes no-     -- command line parameters and nothing on stdin.-     ---     TestSuiteExeV10 Version FilePath--     -- | Test interface \"detailed-0.9\". The test-suite takes the form of a-     -- library containing a designated module that exports \"tests :: [Test]\".-     ---   | TestSuiteLibV09 Version ModuleName--     -- | A test suite that does not conform to one of the above interfaces for-     -- the given reason (e.g. unknown test type).-     ---   | TestSuiteUnsupported TestType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary TestSuiteInterface--instance 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   = testEnabled a || 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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary TestType--knownTestTypes :: [TestType]-knownTestTypes = [ TestTypeExe (Version [1,0] [])-                 , TestTypeLib (Version [0,9] []) ]--stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res-stdParse f = do-  cs   <- Parse.sepBy1 component (Parse.char '-')-  _    <- Parse.char '-'-  ver  <- parse-  let name = intercalate "-" cs-  return $! f ver (lowercase name)-  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).--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 = stdParse $ \ver name -> case name of-    "exitcode-stdio" -> TestTypeExe ver-    "detailed"       -> TestTypeLib ver-    _                -> TestTypeUnknown name ver---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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Benchmark---- | The benchmark interfaces that are currently defined. Each--- benchmark must specify which interface it supports.------ More interfaces may be defined in future, either new revisions or--- totally new interfaces.----data BenchmarkInterface =--     -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark-     -- takes the form of an executable. It returns a zero exit code-     -- for success, non-zero for failure. The stdout and stderr-     -- channels may be logged. It takes no command line parameters-     -- and nothing on stdin.-     ---     BenchmarkExeV10 Version FilePath--     -- | A benchmark that does not conform to one of the above-     -- interfaces for the given reason (e.g. unknown benchmark type).-     ---   | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Generic, Read, Show, Typeable, Data)--instance Binary BenchmarkInterface--instance 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   = benchmarkEnabled a || 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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BenchmarkType--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 = stdParse $ \ver name -> case name of-    "exitcode-stdio" -> BenchmarkTypeExe ver-    _                -> BenchmarkTypeUnknown name ver---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],-        jsSources         :: [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-        extraGHCiLibs     :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.-        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])],-        profOptions       :: [(CompilerFlavor,[String])],-        sharedOptions     :: [(CompilerFlavor,[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-        targetBuildRenaming :: Map PackageName ModuleRenaming-    }-    deriving (Generic, Show, Read, Eq, Typeable, Data)--instance Binary BuildInfo--instance Monoid BuildInfo where-  mempty = BuildInfo {-    buildable         = True,-    buildTools        = [],-    cppOptions        = [],-    ccOptions         = [],-    ldOptions         = [],-    pkgconfigDepends  = [],-    frameworks        = [],-    cSources          = [],-    jsSources         = [],-    hsSourceDirs      = [],-    otherModules      = [],-    defaultLanguage   = Nothing,-    otherLanguages    = [],-    defaultExtensions = [],-    otherExtensions   = [],-    oldExtensions     = [],-    extraLibs         = [],-    extraGHCiLibs     = [],-    extraLibDirs      = [],-    includeDirs       = [],-    includes          = [],-    installIncludes   = [],-    options           = [],-    profOptions       = [],-    sharedOptions     = [],-    customFieldsBI    = [],-    targetBuildDepends = [],-    targetBuildRenaming = Map.empty-  }-  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,-    jsSources         = combineNub jsSources,-    hsSourceDirs      = combineNub hsSourceDirs,-    otherModules      = combineNub otherModules,-    defaultLanguage   = combineMby defaultLanguage,-    otherLanguages    = combineNub otherLanguages,-    defaultExtensions = combineNub defaultExtensions,-    otherExtensions   = combineNub otherExtensions,-    oldExtensions     = combineNub oldExtensions,-    extraLibs         = combine    extraLibs,-    extraGHCiLibs     = combine    extraGHCiLibs,-    extraLibDirs      = combineNub extraLibDirs,-    includeDirs       = combineNub includeDirs,-    includes          = combineNub includes,-    installIncludes   = combineNub installIncludes,-    options           = combine    options,-    profOptions       = combine    profOptions,-    sharedOptions     = combine    sharedOptions,-    customFieldsBI    = combine    customFieldsBI,-    targetBuildDepends = combineNub targetBuildDepends,-    targetBuildRenaming = combineMap targetBuildRenaming-  }-    where-      combine    field = field a `mappend` field b-      combineNub field = nub (combine field)-      combineMby field = field b `mplus` field a-      combineMap field = Map.unionWith mappend (field a) (field b)--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 = lookupHcOptions options--hcProfOptions :: CompilerFlavor -> BuildInfo -> [String]-hcProfOptions = lookupHcOptions profOptions--hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String]-hcSharedOptions = lookupHcOptions sharedOptions--lookupHcOptions :: (BuildInfo -> [(CompilerFlavor,[String])])-                -> CompilerFlavor -> BuildInfo -> [String]-lookupHcOptions f hc bi = [ opt | (hc',opts) <- f 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, Generic, Read, Show, Typeable, Data)--instance Binary SourceRepo---- | What this repo info is for, what it represents.----data RepoKind =-    -- | The repository for the \"head\" or development version of the project.-    -- This repo is where we should track the latest development activity or-    -- the usual repo people should get to contribute patches.-    RepoHead--    -- | The repository containing the sources for this exact package version-    -- or release. For this kind of repo a tag should be given to give enough-    -- information to re-create the exact sources.-  | RepoThis--  | RepoKindUnknown String-  deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoKind---- | 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, Generic, Ord, Read, Show, Typeable, Data)--instance Binary RepoType--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 =-  fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap-  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]        -- ^list with exeName updated-      updateExecutable _                 []         = []-      updateExecutable exe_bi'@(name,bi) (exe:exes)-        | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes-        | otherwise           = exe : updateExecutable exe_bi' exes---- ------------------------------------------------------------------------------ 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, Typeable, Data)--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, Typeable, Data)---- | A 'FlagName' is the name of a user-defined configuration flag-newtype FlagName = FlagName String-    deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary FlagName---- | 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, Typeable, Data)---- | A boolean expression parameterized over the variable type used.-data Condition c = Var c-                 | Lit Bool-                 | CNot (Condition c)-                 | COr (Condition c) (Condition c)-                 | CAnd (Condition c) (Condition c)-    deriving (Show, Eq, Typeable, Data)--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, Typeable, Data)
− Distribution/PackageDescription/Check.hs 
@@ -1,1590 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Check--- Copyright   :  Lennart Kolmodin 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This has code for checking for various problems in packages. There is one--- set of checks that just looks at a 'PackageDescription' in isolation and--- another set of checks that also looks at files in the package. Some of the--- checks are basic sanity checks, others are portability standards that we'd--- like to encourage. There is a 'PackageCheck' type that distinguishes the--- different kinds of 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.--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 qualified Data.Map as Map--import Distribution.PackageDescription-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription, finalizePackageDescription )-import Distribution.Compiler-         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..)-         , unknownCompilerInfo, AbiTag(..) )-import Distribution.System-         ( OS(..), Arch(..), buildPlatform )-import Distribution.License-         ( License(..), knownLicenses )-import Distribution.Simple.CCompiler-         ( filenameCDialect )-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(..), pkgName )--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 detrimental when the package is distributed to-       -- users. We should encourage distributed packages to be free from these-       -- issues, but occasionally there are justifiable reasons so we cannot-       -- ban them entirely.-     | PackageDistSuspicious { explanation :: String }--       -- | An issue that is OK in the author's environment but is almost-       -- certain to be a portability problem for other environments. We can-       -- quite legitimately refuse to publicly distribute packages with these-       -- problems.-     | PackageDistInexcusable { explanation :: String }-  deriving (Eq)--instance Show PackageCheck where-    show notice = explanation notice--check :: Bool -> PackageCheck -> Maybe PackageCheck-check False _  = Nothing-check True  pc = Just pc--checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck-                 -> Maybe PackageCheck-checkSpecVersion pkg specver cond pc-  | specVersion pkg >= Version specver [] = Nothing-  | otherwise                             = check cond pc----- --------------------------------------------------------------- * Standard checks--- ---------------------------------------------------------------- | Check for common mistakes and problems in package descriptions.------ This is the standard collection of checks covering all aspects except--- for checks that require looking at files within the package. For those--- see 'checkPackageFiles'.------ It requires the 'GenericPackageDescription' and optionally a particular--- configuration of that package. If you pass 'Nothing' then we just check--- a version of the generic description using 'flattenPackageDescription'.----checkPackage :: GenericPackageDescription-             -> Maybe PackageDescription-             -> [PackageCheck]-checkPackage gpkg mpkg =-     checkConfiguredPackage pkg-  ++ checkConditionals gpkg-  ++ checkPackageVersions gpkg-  where-    pkg = fromMaybe (flattenPackageDescription gpkg) mpkg----TODO: make this variant go away---      we should always know the GenericPackageDescription-checkConfiguredPackage :: PackageDescription -> [PackageCheck]-checkConfiguredPackage pkg =-    checkSanity pkg- ++ checkFields pkg- ++ checkLicense pkg- ++ checkSourceRepos pkg- ++ checkGhcOptions pkg- ++ checkCCOptions pkg- ++ checkCPPOptions pkg- ++ checkPaths pkg- ++ checkCabalVersion pkg----- --------------------------------------------------------------- * Basic sanity checks--- ---------------------------------------------------------------- | Check that this package description is sane.----checkSanity :: PackageDescription -> [PackageCheck]-checkSanity pkg =-  catMaybes [--    check (null . (\(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    pkg) (library pkg)-  ++ concatMap (checkExecutable pkg) (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 :: PackageDescription -> Library -> [PackageCheck]-checkLibrary pkg lib =-  catMaybes [--    check (not (null moduleDuplicates)) $-       PackageBuildImpossible $-            "Duplicate modules in library: "-         ++ commaSep (map display moduleDuplicates)--    -- check use of required-signatures/exposed-signatures sections-  , checkVersion [1,21] (not (null (requiredSignatures lib))) $-      PackageDistInexcusable $-           "To use the 'required-signatures' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.21'."--  , checkVersion [1,21] (not (null (exposedSignatures lib))) $-      PackageDistInexcusable $-           "To use the 'exposed-signatures' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.21'."-  ]--  where-    checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck-    checkVersion ver cond pc-      | specVersion pkg >= Version ver []      = Nothing-      | otherwise                              = check cond pc--    moduleDuplicates = dups (libModules lib ++-                             map moduleReexportName (reexportedModules lib))--checkExecutable :: PackageDescription -> Executable -> [PackageCheck]-checkExecutable pkg exe =-  catMaybes [--    check (null (modulePath exe)) $-      PackageBuildImpossible $-        "No 'main-is' field found for executable " ++ exeName exe--  , check (not (null (modulePath exe))-       && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $-      PackageBuildImpossible $-           "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor), "-        ++ "or it may specify a C/C++/obj-C source file."--  , checkSpecVersion pkg [1,17]-          (fileExtensionSupportedLanguage (modulePath exe)-        && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $-      PackageDistInexcusable $-           "The package uses a C/C++/obj-C source file for the 'main-is' field. "-        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."--  , check (not (null moduleDuplicates)) $-       PackageBuildImpossible $-            "Duplicate modules in executable '" ++ 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) $-      PackageBuildImpossible $-           "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), "-        ++ "or it may specify a C/C++/obj-C source file."--  , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $-      PackageDistInexcusable $-           "The package uses a C/C++/obj-C source file for the 'main-is' field. "-        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."--    -- 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 -> not $ fileExtensionSupportedLanguage f-      _                   -> False--    mainIsNotHsExt = 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) $-      PackageBuildImpossible $-           "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)-        ++ ". " ++ unwords-             [ "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 == UnspecifiedLicense) $-      PackageDistInexcusable-        "The 'license' field is missing."--  , check (license pkg == AllRightsReserved) $-      PackageDistSuspicious-        "The 'license' is AllRightsReserved. Is that really what you want?"-  , 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-                                 , UnspecifiedLicense, PublicDomain]-           -- AllRightsReserved and PublicDomain are not strictly-           -- licenses so don't need license files.-        && null (licenseFiles pkg)) $-      PackageDistSuspicious "A 'license-file' is not specified."-  ]-  where-    unknownLicenseVersion (GPL  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | GPL  (Just v') <- knownLicenses ]-    unknownLicenseVersion (LGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (AGPL (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]-    unknownLicenseVersion (Apache  (Just v))-      | v `notElem` knownVersions = Just knownVersions-      where knownVersions = [ v' | Apache  (Just v') <- knownLicenses ]-    unknownLicenseVersion _ = Nothing--checkSourceRepos :: PackageDescription -> [PackageCheck]-checkSourceRepos pkg =-  catMaybes $ concat [[--    case repoKind repo of-      RepoKindUnknown kind -> Just $ PackageDistInexcusable $-        quote kind ++ " is not a recognised kind of source-repository. "-                   ++ "The repo kind is usually 'head' or 'this'"-      _ -> Nothing--  , check (isNothing (repoType repo)) $-      PackageDistInexcusable-        "The source-repository 'type' is a required field."--  , check (isNothing (repoLocation repo)) $-      PackageDistInexcusable-        "The source-repository 'location' is a required field."--  , check (repoType repo == Just CVS && isNothing (repoModule repo)) $-      PackageDistInexcusable-        "For a CVS source-repository, the 'module' is a required field."--  , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $-      PackageDistInexcusable $-           "For the 'this' kind of source-repository, the 'tag' is a required "-        ++ "field. It should specify the tag corresponding to this version "-        ++ "or release of the package."--  , check (maybe False 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 $-      PackageDistSuspicious $-           "'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 ["-fdefer-type-errors"] $-      PackageDistInexcusable $-          "'ghc-options: -fdefer-type-errors' is fine during development but "-       ++ "is not appropriate for a distributed package."--  , checkFlags ["-fhpc"] $-      PackageDistInexcusable $-        "'ghc-options: -fhpc' is not appropriate for a distributed package."--    -- -dynamic is not a debug flag-  , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")-           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."--  , checkProfFlags ["-auto-all"] $-      PackageDistSuspicious $-        "'ghc-prof-options: -auto-all' is fine during development, but "-        ++ "not recommended in a distributed package. "--  , checkProfFlags ["-fprof-auto"] $-      PackageDistSuspicious $-        "'ghc-prof-options: -fprof-auto' is fine during development, but "-        ++ "not recommended in a distributed package. "--  , 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, ghc_prof_options) =-      unzip . map (\bi -> (hcOptions GHC bi, hcProfOptions GHC bi))-      $ (allBuildInfo pkg)-    all_ghc_options      = concat ghc_options-    all_ghc_prof_options = concat ghc_prof_options-    lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)--    checkFlags,checkProfFlags :: [String] -> PackageCheck -> Maybe PackageCheck-    checkFlags     flags = doCheckFlags flags all_ghc_options-    checkProfFlags flags = doCheckFlags flags all_ghc_prof_options--    doCheckFlags   flags opts = check (any (`elem` flags) opts)--    ghcExtension ('-':'f':name) = case name of-      "allow-overlapping-instances"    -> enable  OverlappingInstances-      "no-allow-overlapping-instances" -> disable OverlappingInstances-      "th"                             -> enable  TemplateHaskell-      "no-th"                          -> disable TemplateHaskell-      "ffi"                            -> enable  ForeignFunctionInterface-      "no-ffi"                         -> disable ForeignFunctionInterface-      "fi"                             -> enable  ForeignFunctionInterface-      "no-fi"                          -> disable ForeignFunctionInterface-      "monomorphism-restriction"       -> enable  MonomorphismRestriction-      "no-monomorphism-restriction"    -> disable MonomorphismRestriction-      "mono-pat-binds"                 -> enable  MonoPatBinds-      "no-mono-pat-binds"              -> disable MonoPatBinds-      "allow-undecidable-instances"    -> enable  UndecidableInstances-      "no-allow-undecidable-instances" -> disable UndecidableInstances-      "allow-incoherent-instances"     -> enable  IncoherentInstances-      "no-allow-incoherent-instances"  -> disable IncoherentInstances-      "arrows"                         -> enable  Arrows-      "no-arrows"                      -> disable Arrows-      "generics"                       -> enable  Generics-      "no-generics"                    -> disable Generics-      "implicit-prelude"               -> enable  ImplicitPrelude-      "no-implicit-prelude"            -> disable ImplicitPrelude-      "implicit-params"                -> enable  ImplicitParams-      "no-implicit-params"             -> disable ImplicitParams-      "bang-patterns"                  -> enable  BangPatterns-      "no-bang-patterns"               -> disable BangPatterns-      "scoped-type-variables"          -> enable  ScopedTypeVariables-      "no-scoped-type-variables"       -> disable ScopedTypeVariables-      "extended-default-rules"         -> enable  ExtendedDefaultRules-      "no-extended-default-rules"      -> disable ExtendedDefaultRules-      _                                -> Nothing-    ghcExtension "-cpp"             = enable CPP-    ghcExtension _                  = Nothing--    enable  e = Just (EnableExtension e)-    disable e = Just (DisableExtension e)--checkCCOptions :: PackageDescription -> [PackageCheck]-checkCCOptions 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)--checkCPPOptions :: PackageDescription -> [PackageCheck]-checkCPPOptions pkg =-  catMaybes [-    checkAlternatives "cpp-options" "include-dirs"-      [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]-    ]-  where all_cppOptions = [ opts | bi <- allBuildInfo pkg-                                , opts <- cppOptions bi ]--checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck-checkAlternatives badField goodField flags =-  check (not (null badFlags)) $-    PackageBuildWarning $-         "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)-      ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)--  where (badFlags, goodFlags) = unzip flags--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, "extra-doc-files") | path <- extraDocFiles pkg ]-      ++ [ (path, "data-files")      | path <- dataFiles     pkg ]-      ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]-      ++ concat-         [    [ (path, "c-sources")        | path <- cSources        bi ]-           ++ [ (path, "js-sources")       | path <- jsSources       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 reexported-modules sections-  , checkVersion [1,21]-    (maybe False (not.null.reexportedModules) (library pkg)) $-      PackageDistInexcusable $-           "To use the 'reexported-module' field the package needs to specify "-        ++ "at least 'cabal-version: >= 1.21'."--    -- check use of thinning and renaming-  , checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $-      PackageDistInexcusable $-           "The package uses "-        ++ "thinning and renaming in the 'build-depends' field: "-        ++ commaSep (map display depsUsingThinningRenamingSyntax)-        ++ ". To use this new syntax, the package needs to specify at least"-        ++ "'cabal-version: >= 1.21'."--    -- 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 compatibility "-        ++ "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 compatibility "-        ++ "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 compatibility 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 "-        ++ "compatibility 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 "-        ++ "compatibility 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 "-        ++ "compatibility 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 "-        ++ "compatibility 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 ]--    -- XXX: If the user writes build-depends: foo with (), this is-    -- indistinguishable from build-depends: foo, so there won't be an-    -- error even though there should be-    depsUsingThinningRenamingSyntax =-      [ name-      | bi <- allBuildInfo pkg-      , (name, rns) <- Map.toList (targetBuildRenaming bi)-      , rns /= ModuleRenaming True [] ]--    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, AGPL Nothing, BSD3, BSD4-                     , PublicDomain, AllRightsReserved-                     , UnspecifiedLicense, 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 presence 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 unbounded above.-    -- However that's a bit tricky because there are many possible-    -- configurations. As a cheap easy and safe approximation we will-    -- pick a single "typical" configuration and check if that has an-    -- open upper bound. To get a typical configuration we finalise-    -- using no package index and the current platform.-    finalised = finalizePackageDescription-                              [] (const True) buildPlatform-                              (unknownCompilerInfo-                                (CompilerId buildCompilerFlavor (Version [] [])) NoAbiTag)-                              [] 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 file path.----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-  licenseErrors   <- checkLicensesExist   ops pkg-  setupError      <- checkSetupExists     ops pkg-  configureError  <- checkConfigureExists ops pkg-  localPathErrors <- checkLocalPathsExist ops pkg-  vcsLocation     <- checkMissingVcsInfo  ops pkg--  return $ licenseErrors-        ++ catMaybes [setupError, configureError]-        ++ localPathErrors-        ++ vcsLocation--checkLicensesExist :: Monad m => CheckPackageContentOps m-                   -> PackageDescription-                   -> m [PackageCheck]-checkLicensesExist ops pkg = do-    exists <- mapM (doesFileExist ops) (licenseFiles pkg)-    return-      [ PackageBuildWarning $-           "The '" ++ fieldname ++ "' field refers to the file "-        ++ quote file ++ " which does not exist."-      | (file, False) <- zip (licenseFiles pkg) exists ]-  where-    fieldname | length (licenseFiles pkg) == 1 = "license-file"-              | otherwise                      = "license-files"--checkSetupExists :: Monad m => CheckPackageContentOps m-                 -> PackageDescription-                 -> m (Maybe PackageCheck)-checkSetupExists ops _ = 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. "-      ++ "You probably need to run 'autoreconf -i' to generate it."-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) ]--fileExtensionSupportedLanguage :: FilePath -> Bool-fileExtensionSupportedLanguage path =-    isHaskell || isC-  where-    extension = takeExtension path-    isHaskell = extension `elem` [".hs", ".lhs"]-    isC       = isJust (filenameCDialect extension)
− Distribution/PackageDescription/Configuration.hs 
@@ -1,609 +0,0 @@-{-# LANGUAGE CPP #-}--- -fno-warn-deprecations for use of Map.foldWithKey-{-# OPTIONS_GHC -fno-warn-deprecations #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Configuration--- Copyright   :  Thomas Schilling, 2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is about the cabal configurations feature. It exports--- '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.--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.PackageDescription.Utils-         ( cabalBug, userBug )-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.Simple.Compiler-         ( CompilerInfo(..) )--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-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#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 -> CompilerInfo -> Condition ConfVar-                      -> (Condition FlagName, [FlagName])-simplifyWithSysParams os arch cinfo cond = (cond', flags)-  where-    (cond', flags) = simplifyCondition cond interp-    interp (OS os')    = Right $ os' == os-    interp (Arch arch') = Right $ arch' == arch-    interp (Impl comp vr)-      | matchImpl (compilerInfoId cinfo) = Right True-      | otherwise = case compilerInfoCompat cinfo of-          -- fixme: treat Nothing as unknown, rather than empty list once we-          --        support partial resolution of system parameters-          Nothing     -> Right False-          Just compat -> Right (any matchImpl compat)-          where-            matchImpl (CompilerId c v) = comp == c && v `withinRange` vr-    interp (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 constraints of all trees.------ Returns either the missing dependencies, or a tuple containing the--- resulting data, the associated dependencies, and the chosen flag--- assignments.------ In case of failure, the _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-  -> CompilerInfo  -- ^ Compiler information-  -> [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 }-  deriving (Show, Read)--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) =-    mconcat $ (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 _, _, _, _) = userBug "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 =-          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) tests =-          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"-        | any ((== n) . fst) bms =-          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"-        | otherwise = (mlib, (n, e'):exes, tests, bms)-      where-        e' = e {-                buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Test n t) (mlib, exes, tests, bms)-        | any ((== n) . fst) tests =-          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) exes =-          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"-        | any ((== n) . fst) bms =-          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"-        | otherwise = (mlib, exes, (n, t'):tests, bms)-      where-        t' = t {-            testBuildInfo = (testBuildInfo t)-                { targetBuildDepends = fromDepMap deps }-            }-    untag (deps, Bench n b) (mlib, exes, tests, bms)-        | any ((== n) . fst) bms =-          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"-        | any ((== n) . fst) exes =-          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"-        | any ((== n) . fst) tests =-          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"-        | otherwise = (mlib, exes, tests, (n, b'):bms)-      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` _ = cabalBug "Cannot combine incompatible tags"---- | Create a package description with all configurations resolved.------ This function takes a `GenericPackageDescription` and several environment--- parameters and tries to generate `PackageDescription` by finding a flag--- assignment that result in satisfiable dependencies.------ It takes as inputs a not necessarily complete specifications of flags--- assignments, an optional package index as well as platform parameters.  If--- some flags are not assigned explicitly, this function will try to pick an--- assignment that causes this function to succeed.  The package index is--- optional since on some platforms we cannot determine which packages have--- been installed before.  When no package index is supplied, every dependency--- is assumed to be satisfiable, therefore all not explicitly assigned flags--- will get their default values.------ This function will fail if it cannot find a flag assignment that leads to--- satisfiable dependencies.  (It will not try alternative assignments for--- explicitly specified flags.)  In case of failure it will return 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 dependency satisfiable from the set of-                          -- available packages?  If this is unknown then use-                          -- True.-  -> Platform      -- ^ The 'Arch' and 'OS'-  -> CompilerInfo  -- ^ Compiler information-  -> [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     = let missingDeps = filter (not . satisfyDep) ds-                   in if null missingDeps-                      then DepOk-                      else MissingDeps missingDeps--{--let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])-let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])--let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]-let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index-let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks   ===>  Right ...-resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks  ===>  Left ...--}---- | Flatten a generic package description by ignoring all conditions and just--- join the field descriptors into on package description.  Note, however,--- that this may lead to inconsistent field values, since all values are--- joined into one field, which may not be possible in the original package--- description, due to the use of exclusive choices (if ... else ...).------ TODO: One particularly tricky case is defaulting.  In the original package--- description, e.g., the source directory might either be the default or a--- certain, explicitly set path.  Since defaults are filled in only after the--- package has been resolved and when no explicit value has been set, the--- default path will be missing from the package description returned by this--- function.-flattenPackageDescription :: GenericPackageDescription -> PackageDescription-flattenPackageDescription (GenericPackageDescription pkg _ mlib0 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
− Distribution/PackageDescription/Parse.hs 
@@ -1,1279 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Parse--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defined parsers and partial pretty printers for the @.cabal@ format.--- 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.--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)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid ( Monoid(..) )-#endif-import Data.List  (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless, ap)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Arrow (first)-import System.Directory (doesFileExist)-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.Typeable-import Data.Data-import qualified Data.Map as Map--import Distribution.Text-         ( Text(disp, parse), display, simpleParse )-import Distribution.Compat.ReadP-         ((+++), option)-import qualified Distribution.Compat.ReadP as Parse-import Text.PrettyPrint--import Distribution.ParseUtils hiding (parseFields)-import Distribution.PackageDescription-import Distribution.PackageDescription.Utils-         ( cabalBug, userBug )-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})-   -- We have both 'license-file' and 'license-files' fields.-   -- Rather than declaring license-file to be deprecated, we will continue-   -- to allow both. The 'license-file' will continue to only allow single-   -- tokens, while 'license-files' allows multiple. On pretty-printing, we-   -- will use 'license-file' if there's just one, and use 'license-files'-   -- otherwise.- , simpleField "license-file"-           showFilePath           parseFilePathQ-           (\pkg -> case licenseFiles pkg of-                      [x] -> x-                      _   -> "")-           (\l pkg -> pkg{licenseFiles=licenseFiles pkg ++ [l]})- , listField "license-files"-           showFilePath           parseFilePathQ-           (\pkg -> case licenseFiles pkg of-                      [_] -> []-                      xs  -> xs)-           (\ls pkg -> pkg{licenseFiles=ls})- , 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 "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})- , listFieldWithSep vcat "data-files"-           showFilePath           parseFilePathQ-           dataFiles              (\val pkg -> pkg{dataFiles=val})- , simpleField "data-dir"-           showFilePath           parseFilePathQ-           dataDir                (\val pkg -> pkg{dataDir=val})- , listFieldWithSep vcat "extra-source-files"-           showFilePath    parseFilePathQ-           extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})- , listFieldWithSep vcat "extra-tmp-files"-           showFilePath       parseFilePathQ-           extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})- , listFieldWithSep vcat "extra-doc-files"-           showFilePath    parseFilePathQ-           extraDocFiles          (\val pkg -> pkg{extraDocFiles=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 =-  [ listFieldWithSep vcat "exposed-modules" disp parseModuleNameQ-      exposedModules (\mods lib -> lib{exposedModules=mods})--  , commaListFieldWithSep vcat "reexported-modules" disp parse-      reexportedModules (\mods lib -> lib{reexportedModules=mods})--  , listFieldWithSep vcat "required-signatures" disp parseModuleNameQ-      requiredSignatures (\mods lib -> lib{requiredSignatures=mods})--  , listFieldWithSep vcat "exposed-signatures" disp parseModuleNameQ-      exposedSignatures (\mods lib -> lib{exposedSignatures=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})- , commaListFieldWithSep vcat "build-depends"-           disp                   parse-           buildDependsWithRenaming-           setBuildDependsWithRenaming- , 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})- , listFieldWithSep vcat "c-sources"-           showFilePath       parseFilePathQ-           cSources           (\paths binfo -> binfo{cSources=paths})- , listFieldWithSep vcat "js-sources"-           showFilePath       parseFilePathQ-           jsSources          (\paths binfo -> binfo{jsSources=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})-- , listFieldWithSep vcat "extra-libraries"-           showToken          parseTokenQ-           extraLibs          (\xs    binfo -> binfo{extraLibs=xs})- , listFieldWithSep vcat "extra-ghci-libraries"-           showToken          parseTokenQ-           extraGHCiLibs      (\xs    binfo -> binfo{extraGHCiLibs=xs})- , listField   "extra-lib-dirs"-           showFilePath       parseFilePathQ-           extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})- , listFieldWithSep vcat "includes"-           showFilePath       parseFilePathQ-           includes           (\paths binfo -> binfo{includes=paths})- , listFieldWithSep vcat "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})- , listFieldWithSep vcat "other-modules"-           disp               parseModuleNameQ-           otherModules       (\val binfo -> binfo{otherModules=val})- , optsField   "ghc-prof-options" GHC-           profOptions        (\val binfo -> binfo{profOptions=val})- , optsField   "ghcjs-prof-options" GHCJS-           profOptions        (\val binfo -> binfo{profOptions=val})- , optsField   "ghc-shared-options" GHC-           sharedOptions      (\val binfo -> binfo{sharedOptions=val})- , optsField   "ghcjs-shared-options" GHCJS-           sharedOptions      (\val binfo -> binfo{sharedOptions=val})- , optsField   "ghc-options"  GHC-           options            (\path  binfo -> binfo{options=path})- , optsField   "ghcjs-options" GHCJS-           options            (\path  binfo -> binfo{options=path})- , optsField   "jhc-options"  JHC-           options            (\path  binfo -> binfo{options=path})-- -- NOTE: Hugs and NHC are not supported anymore, but these fields are kept- -- around for backwards compatibility.- , optsField   "hugs-options" Hugs-           options            (const id)- , optsField   "nhc98-options" NHC-           options            (const id)- ]--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-  unless 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 = mapM walk-  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 [DependencyWithRenaming]-parseConstraint (F l n v)-    | n == "build-depends" = runP l n (parseCommaList parse) v-parseConstraint f = userBug $ "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 Functor f => Functor (StT s f) where-    fmap g (StT f) = StT $ fmap (first g)  . f--instance (Monad m, Functor m) => Applicative (StT s m) where-    pure = return-    (<*>) = ap--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 = liftM fst $ runStT st s---- 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 = liftM listToMaybe get---- 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 = all isSimpleField-    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 implementation 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 _ = cabalBug "unexpected 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-            unless (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@(F {}) -> do-            _ <- lift $ syntaxError (lineNo f) $-              "Plain fields are not allowed in between stanzas: " ++ show f-            skipField-            getBody-      Just f@(IfBlock {}) -> do-            _ <- lift $ syntaxError (lineNo f) $-              "If-blocks are not allowed in between stanzas: " ++ 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 ]-            sections = [ s | s@Section{} <- allflds ]--        -- Put these through the normal parsing pass too, so that we-        -- collect the ModRenamings-        let depFlds = filter isConstraint simplFlds-        -        mapM_-            (\(Section l n _ _) -> lift . warning $-                "Unexpected section '" ++ n ++ "' on line " ++ show l)-            sections--        a <- parser simplFlds-        deps <- liftM concat . mapM (lift . fmap (map dependency) .  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 _ = cabalBug "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-        unless (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-       unless (null unknowns) $ 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 _ _ _ _ = cabalBug "'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 _ = cabalBug "'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 (_:_) = cabalBug "`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 . BS.Char8.pack-                             . 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" ]---- | Dependencies plus module renamings.  This is what users specify; however,--- renaming information is not used for dependency resolution.-data DependencyWithRenaming = DependencyWithRenaming Dependency ModuleRenaming-  deriving (Read, Show, Eq, Typeable, Data)--dependency :: DependencyWithRenaming -> Dependency-dependency (DependencyWithRenaming dep _) = dep--instance Text DependencyWithRenaming where-  disp (DependencyWithRenaming d rns) = disp d <+> disp rns-  parse = do d <- parse-             Parse.skipSpaces-             rns <- parse-             Parse.skipSpaces-             return (DependencyWithRenaming d rns)--buildDependsWithRenaming :: BuildInfo -> [DependencyWithRenaming]-buildDependsWithRenaming pkg =-    map (\dep@(Dependency n _) ->-            DependencyWithRenaming dep-                (Map.findWithDefault defaultRenaming n (targetBuildRenaming pkg)))-        (targetBuildDepends pkg)--setBuildDependsWithRenaming :: [DependencyWithRenaming] -> BuildInfo -> BuildInfo-setBuildDependsWithRenaming deps pkg = pkg {-    targetBuildDepends = map dependency deps,-    targetBuildRenaming = Map.fromList (map (\(DependencyWithRenaming (Dependency n _) rns) -> (n, rns)) deps)-  }
− Distribution/PackageDescription/PrettyPrint.hs 
@@ -1,243 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.PrettyPrint--- Copyright   :  Jürgen Nicklisch-Franken 2010--- License     :  BSD3------ Maintainer  : cabal-devel@haskell.org--- Stability   : provisional--- Portability : portable------ Pretty printing for cabal files-----------------------------------------------------------------------------------module Distribution.PackageDescription.PrettyPrint (-    writeGenericPackageDescription,-    showGenericPackageDescription,-) where--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(mempty))-#endif-import Distribution.PackageDescription-       ( Benchmark(..), BenchmarkInterface(..), benchmarkType-       , TestSuite(..), TestSuiteInterface(..), testType-       , SourceRepo(..),-        customFieldsBI, CondTree(..), Condition(..),-        FlagName(..), ConfVar(..), Executable(..), Library(..),-        Flag(..), PackageDescription(..),-        GenericPackageDescription(..))-import Text.PrettyPrint-       (hsep, parens, char, nest, empty,-        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)-import Distribution.Simple.Utils (writeUTF8File)-import Distribution.ParseUtils (showFreeText, FieldDescr(..), indentWith, ppField, ppFields)-import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,-       sourceRepoFieldDescrs,flagFieldDescrs)-import Distribution.Package (Dependency(..))-import Distribution.Text (Text(..))-import Data.Maybe (isJust, fromJust, isNothing)---- | 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)-        $+$ ppBenchmarks (condBenchmarks 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"]---- TODO: this is a temporary hack. Ideally, fields containing default values--- would be filtered out when the @FieldDescr a@ list is generated.-ppFieldsFiltered :: [(String, String)] -> [FieldDescr a] -> a -> Doc-ppFieldsFiltered removable fields x = ppFields (filter nondefault fields) x-  where-    nondefault (FieldDescr name getter _) =-        maybe True (render (getter x) /=) (lookup name removable)--binfoDefaults :: [(String, String)]-binfoDefaults = [("buildable", "True")]--libDefaults :: [(String, String)]-libDefaults = ("exposed", "True") : binfoDefaults--flagDefaults :: [(String, String)]-flagDefaults = [("default", "True"), ("manual", "False")]--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 flag@(MkFlag name _ _ _)    =-    emptyLine $ text "flag" <+> ppFlagName name $+$ nest indentWith fields-  where-    fields = ppFieldsFiltered flagDefaults flagFieldDescrs flag--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     = ppFieldsFiltered libDefaults 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')-            $+$ ppFieldsFiltered binfoDefaults 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 =-                maybe empty (\t -> text "type:"        <+> disp t)-                            maybeTestType-            $+$ maybe empty (\f -> text "main-is:"     <+> text f)-                            (testSuiteMainIs testsuite)-            $+$ maybe empty (\m -> text "test-module:" <+> disp m)-                            (testSuiteModule testsuite)-            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (testBuildInfo testsuite)-            $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))-      where-        maybeTestType | testInterface testsuite == mempty = Nothing-                      | otherwise = Just (testType 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--ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc-ppBenchmarks suites =-    emptyLine $ vcat [     text ("benchmark " ++ n)-                       $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)-                     | (n,condTree) <- suites]-  where-    ppBenchmark benchmark Nothing =-                maybe empty (\t -> text "type:"        <+> disp t)-                            maybeBenchmarkType-            $+$ maybe empty (\f -> text "main-is:"     <+> text f)-                            (benchmarkMainIs benchmark)-            $+$ ppFieldsFiltered binfoDefaults binfoFieldDescrs (benchmarkBuildInfo benchmark)-            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))-      where-        maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing-                           | otherwise = Just (benchmarkType benchmark)--    ppBenchmark (Benchmark _ _ buildInfo' _)-                    (Just (Benchmark _ _ buildInfo2 _)) =-            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2-            $+$ ppCustomFields (customFieldsBI buildInfo')--    benchmarkMainIs benchmark = case benchmarkInterface benchmark of-      BenchmarkExeV10 _ f -> Just f-      _                   -> 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 _ ifs) mbIt ppIt =-    let res = (vcat $ map ppIf ifs)-                $+$ ppIt it mbIt-    in if isJust mbIt && isEmpty res-        then ppCondTree ct Nothing ppIt-        else res-  where-    -- TODO: this ends up printing trailing spaces when combined with nest.-    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))--emptyLine :: Doc -> Doc-emptyLine d                              = text "" $+$ d---
− Distribution/PackageDescription/Utils.hs 
@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.PackageDescription.Utils------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Common utils used by modules under Distribution.PackageDescription.*.--module Distribution.PackageDescription.Utils (-  cabalBug, userBug-  ) where---- ------------------------------------------------------------------------------- Exception and logging utils--userBug :: String -> a-userBug msg = error $ msg ++ ". This is a bug in your .cabal file."--cabalBug :: String -> a-cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"-               ++ "Please report it to the developers: "-               ++ "https://github.com/haskell/cabal/issues/new"
− Distribution/ParseUtils.hs 
@@ -1,755 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.ParseUtils--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD3------ 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.---- This module is meant to be local-only to Distribution...--{-# OPTIONS_HADDOCK 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, showSimpleSingleNamedField,-        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, listFieldWithSep, spaceListField,-        commaListField, commaListFieldWithSep, commaNewLineListField,-        optsField, liftField, boolField, parseQuoted, indentWith,--        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, dropWhileEndLE, 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, ap)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import System.FilePath (normalise)-import Data.List (sortBy)---- -------------------------------------------------------------------------------type LineNo    = Int-type Separator = ([Doc] -> Doc)--data PError = AmbiguousParse String LineNo-            | NoParse String LineNo-            | TabsError LineNo-            | FromString String (Maybe LineNo)-        deriving (Eq, Show)--data PWarning = PWarning String-              | UTFWarning LineNo String-        deriving (Eq, Show)--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 Functor ParseResult where-        fmap _ (ParseFailed err) = ParseFailed err-        fmap f (ParseOk ws x) = ParseOk ws $ f x--instance Applicative ParseResult where-        pure = return-        (<*>) = ap---instance Monad ParseResult where-        return = ParseOk []-        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 (AmbiguousParse fieldname line)-    _   -> ParseFailed (AmbiguousParse fieldname line)-  where results = readP_to_S p s--runE :: LineNo -> String -> ReadE a -> String -> ParseResult a-runE line fieldname p s =-    case runReadE p s of-      Right a -> ParseOk (utf8Warnings line fieldname s) a-      Left  e -> syntaxError line $-        "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 (AmbiguousParse f n) = (Just n,-                                        "Ambiguous parse in field '"++f++"'.")-locatedErrorMsg (NoParse f n)        = (Just n,-                                        "Parse of field '"++f++"' failed.")-locatedErrorMsg (TabsError n)        = (Just n, "Tab used as indentation.")-locatedErrorMsg (FromString s n)     = (n, s)--syntaxError :: LineNo -> String -> ParseResult a-syntaxError n s = ParseFailed $ FromString s (Just n)--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 (showF . get)-        (\line str b -> do-            a <- parseF line str (get b)-            return (set a b))---- Parser combinator for simple fields.  Takes a field name, a pretty printer,--- a parser function, an accessor, and a setter, returns a FieldDescr over the--- compoid structure.-simpleField :: String -> (a -> Doc) -> ReadP a a-            -> (b -> a) -> (a -> b -> b) -> FieldDescr b-simpleField name showF readF get set-  = liftField get set $ field name showF readF--commaListFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a-                      -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListFieldWithSep separator name showF readF get set =-   liftField get set' $-     field name showF' (parseCommaList readF)-   where-     set' xs b = set (get b ++ xs) b-     showF'    = separator . punctuate comma . map showF--commaListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaListField = commaListFieldWithSep fsep--commaNewLineListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-commaNewLineListField = commaListFieldWithSep sep--spaceListField :: String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-spaceListField name showF readF get set =-  liftField get set' $-    field name showF' (parseSpaceList readF)-  where-    set' xs b = set (get b ++ xs) b-    showF'    = fsep . map showF--listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a-                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listFieldWithSep separator name showF readF get set =-  liftField get set' $-    field name showF' (parseOptCommaList readF)-  where-    set' xs b = set (get b ++ xs) b-    showF'    = separator . map showF--listField :: String -> (a -> Doc) -> ReadP [a] a-          -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b-listField = listFieldWithSep fsep--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 showF (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)-        showF   = hsep . map text---- 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 framework!-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-   | isEmpty fielddoc         = empty-   | name `elem` nestedFields = text name <> colon $+$ nest indentWith fielddoc-   | otherwise                = text name <> colon <+> fielddoc-   where-      nestedFields =-         [ "description"-         , "build-depends"-         , "data-files"-         , "extra-source-files"-         , "extra-tmp-files"-         , "exposed-modules"-         , "c-sources"-         , "js-sources"-         , "extra-libraries"-         , "includes"-         , "install-includes"-         , "other-modules"-         , "depends"-         ]--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)--showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)-showSimpleSingleNamedField fields f =-  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of-    []      -> Nothing-    (get:_) -> Just (renderStyle myStyle . get)- where myStyle = style { mode = LeftMode }--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 _ = Just------------------------------------------------------------------------------------ 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 in between.--- 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 = dropWhileEndLE isSpace---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 brackets, unexpected {"-    CloseBracket n:_ -> syntaxError n "mismatched brackets, 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--betweenSpaces :: ReadP r a -> ReadP r a-betweenSpaces act = do skipSpaces-                       res <- act-                       skipSpaces-                       return res--parseBuildTool :: ReadP r Dependency-parseBuildTool = do name <- parseBuildToolNameQ-                    ver <- betweenSpaces $-                           parseVersionRangeQ <++ return anyVersion-                    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` "+-._")-                              ver <- betweenSpaces $-                                     parseVersionRangeQ <++ return anyVersion-                              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 [] []--parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)-parseTestedWithQ = parseQuoted tw <++ tw-  where-    tw :: ReadP r (CompilerFlavor,VersionRange)-    tw = do compiler <- parseCompilerFlavorCompat-            version <- betweenSpaces $ parse <++ return anyVersion-            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 (not . isSpace)--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 = betweenSpaces sepr--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 = between (ReadP.char '"') (ReadP.char '"')--parseFreeText :: ReadP.ReadP s String-parseFreeText = ReadP.munch (const True)---- ----------------------------------------------- ** Pretty printing--showFilePath :: FilePath -> Doc-showFilePath "" = empty-showFilePath x  = showToken x--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 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''---- | the indentation used for pretty printing-indentWith :: Int-indentWith = 4
− Distribution/ReadE.hs 
@@ -1,51 +0,0 @@--------------------------------------------------------------------------------- |--- 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-   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,700 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is the command line front end to the Simple build system. When given--- the parsed command-line args and package information, is able to perform--- basic commands like configure, build, install, register, etc.------ This module exports the main functions that Setup.hs scripts use. It--- re-exports the 'UserHooks' type, the standard entry points like--- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of--- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own--- behaviour.------ This module isn't called \"Simple\" because it's simple.  Far from--- it.  It's called \"Simple\" because it does complicated things to--- simple software.------ The original idea was that there could be different build systems that all--- presented the same compatible command line interfaces. There is still a--- "Distribution.Make" system but in practice no packages use it.--{--Work around this warning:-libraries/Cabal/Distribution/Simple.hs:78:0:-    Warning: In the use of `runTests'-             (imported from Distribution.Simple.UserHooks):-             Deprecated: "Please use the new testing interface instead!"--}-{-# OPTIONS_GHC -fno-warn-deprecations #-}--module Distribution.Simple (-        module Distribution.Package,-        module Distribution.Version,-        module Distribution.License,-        module Distribution.Simple.Compiler,-        module Language.Haskell.Extension,-        -- * Simple interface-        defaultMain, defaultMainNoRead, defaultMainArgs,-        -- * Customization-        UserHooks(..), Args,-        defaultMainWithHooks, defaultMainWithHooksArgs,-        -- ** 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 module.-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, repl )-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)-import System.Directory(removeFile, doesFileExist,-                        doesDirectoryExist, removeDirectoryRecursive)-import System.Exit       (exitWith,ExitCode(..))-import System.IO.Error   (isDoesNotExistError)-import Control.Exception (throwIO)-import Distribution.Compat.Environment (getEnvironment)-import Distribution.Compat.Exception (catchIO)--import Control.Monad   (when)-import Data.List       (intercalate, 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) commands args of-    CommandHelp   help                 -> printHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (flags, commandParse)  ->-      case commandParse of-        _ | fromFlag (globalVersion flags)        -> printVersion-          | fromFlag (globalNumericVersion flags) -> printNumericVersion-        CommandHelp     help           -> printHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action--  where-    printHelp help = getProgName >>= putStr . help-    printOptionsList = putStr . unlines-    printErrors errs = do-      putStr (intercalate "\n" errs)-      exitWith (ExitFailure 1)-    printNumericVersion = putStrLn $ 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-      ,replCommand      progs `commandAddAction` replAction         hooks-      ,installCommand         `commandAddAction` installAction      hooks-      ,copyCommand            `commandAddAction` copyAction         hooks-      ,haddockCommand         `commandAddAction` haddockAction      hooks-      ,cleanCommand           `commandAddAction` cleanAction        hooks-      ,sdistCommand           `commandAddAction` sdistAction        hooks-      ,hscolourCommand        `commandAddAction` hscolourAction     hooks-      ,registerCommand        `commandAddAction` registerAction     hooks-      ,unregisterCommand      `commandAddAction` unregisterAction   hooks-      ,testCommand            `commandAddAction` testAction         hooks-      ,benchmarkCommand       `commandAddAction` benchAction        hooks-      ]---- | Combine the preprocessors in the given hooks with the--- preprocessors built into cabal.-allSuffixHandlers :: UserHooks-                  -> [PPSuffixHandler]-allSuffixHandlers hooks-    = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers-    where-      overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]-      overridesPP = unionBy (\x y -> fst x == fst y)--configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo-configureAction hooks flags args = do-                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 { buildArgs = args } args--replAction :: UserHooks -> ReplFlags -> Args -> IO ()-replAction hooks flags args = do-  let distPref  = fromFlag $ replDistPref flags-      verbosity = fromFlag $ replVerbosity flags--  lbi <- getBuildConfig hooks verbosity distPref-  progs <- reconfigurePrograms verbosity-             (replProgramPaths flags)-             (replProgramArgs flags)-             (withPrograms lbi)--  pbi <- preRepl hooks args flags-  let lbi' = lbi { withPrograms = progs }-      pkg_descr0 = localPkgDescr lbi'-      pkg_descr = updatePackageDescription pbi pkg_descr0-  replHook hooks pkg_descr lbi' hooks flags args-  postRepl hooks args flags pkg_descr lbi'--hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()-hscolourAction hooks flags args-    = do 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-    hookedActionWithArgs 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 configure 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 when isFile $ removeFile fname-        verbosity = fromFlag (cleanVerbosity flags)---- ----------------------------------------------------------------------------- Default hooks---- | Hooks that correspond to a plain instantiation of the--- \"simple\" build system-simpleUserHooks :: UserHooks-simpleUserHooks =-    emptyUserHooks {-       confHook  = configure,-       postConf  = finalChecks,-       buildHook = defaultBuildHook,-       replHook  = defaultReplHook,-       copyHook  = \desc lbi _ f -> install desc lbi f, -- 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:-    -- https://github.com/haskell/cabal/issues/158-    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    = \_ flags ->-                       -- not using 'readHook' here because 'build' takes-                       -- extra args-                       getHookedBuildInfo $ fromFlag $ buildVerbosity flags,-       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 throwIO 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 :: Args -> PackageDescription -> LocalBuildInfo-                -> UserHooks -> TestFlags -> IO ()-defaultTestHook args pkg_descr localbuildinfo _ flags =-    test args pkg_descr localbuildinfo flags--defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo-                 -> UserHooks -> BenchmarkFlags -> IO ()-defaultBenchHook args pkg_descr localbuildinfo _ flags =-    bench args pkg_descr localbuildinfo flags--defaultInstallHook :: PackageDescription -> LocalBuildInfo-                   -> UserHooks -> InstallFlags -> IO ()-defaultInstallHook pkg_descr localbuildinfo _ flags = do-  let copyFlags = defaultCopyFlags {-                      copyDistPref   = installDistPref flags,-                      copyDest       = 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)--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 verbosity-           "Package contains no library to register:" (packageId pkg_descr)-  where verbosity = fromFlag (regVerbosity flags)
− Distribution/Simple/Bench.hs 
@@ -1,128 +0,0 @@--------------------------------------------------------------------------------- |--- 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 qualified Distribution.PackageDescription as PD-    ( PackageDescription(..), BuildInfo(buildable)-    , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )-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--- 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.pkgKey lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
− Distribution/Simple/Build.hs 
@@ -1,605 +0,0 @@--------------------------------------------------------------------------------- |--- 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, repl,-    startInterpreter,--    initialBuildSteps,-    writeAutogenFiles,-  ) where--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.JHC   as JHC-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite--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, mkPackageKey, packageName )-import Distribution.Simple.Compiler-         ( Compiler, CompilerFlavor(..), compilerFlavor-         , PackageDB(..), PackageDBStack, packageKeySupported )-import Distribution.PackageDescription-         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)-         , TestSuite(..), TestSuiteInterface(..), Benchmark(..)-         , BenchmarkInterface(..), defaultRenaming )-import qualified Distribution.InstalledPackageInfo as IPI-import qualified Distribution.ModuleName as ModuleName-import Distribution.ModuleName (ModuleName)--import Distribution.Simple.Setup-         ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )-import Distribution.Simple.BuildTarget-         ( BuildTarget(..), readBuildTargets )-import Distribution.Simple.PreProcess-         ( preprocessComponent, PPSuffixHandler )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms, pkgKey)-         , Component(..), componentName, getComponent, componentBuildInfo-         , ComponentLocalBuildInfo(..), pkgEnabledComponents-         , withComponentsInBuildOrder, componentsInBuildOrder-         , ComponentName(..), showComponentName-         , ComponentDisabledReason(..), componentDisabledReason-         , inplacePackageId, LibraryName(..) )-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Db-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.BuildPaths-         ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )-import Distribution.Simple.Register-         ( registerPackage, inplaceInstalledPackageInfo )-import Distribution.Simple.Test.LibV09 ( stubFilePath, stubName )-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, rewriteFile-         , die, info, debug, warn, setupMessage )--import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text-         ( display )--import qualified Data.Map as Map-import Data.Maybe-         ( maybeToList )-import Data.Either-         ( partitionEithers )-import Data.List-         ( intersect, intercalate )-import Control.Monad-         ( when, unless, forM_ )-import System.FilePath-         ( (</>), (<.>) )-import System.Directory-         ( getCurrentDirectory, removeDirectoryRecursive, removeFile-         , doesDirectoryExist, doesFileExist )---- -------------------------------------------------------------------------------- |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)--  targets  <- readBuildTargets pkg_descr (buildArgs flags)-  targets' <- checkBuildTargets verbosity pkg_descr targets-  let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))-  info verbosity $ "Component build order: "-                ++ intercalate ", " (map showComponentName componentsToBuild)--  initialBuildSteps distPref pkg_descr lbi verbosity-  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--  withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->-    let bi     = componentBuildInfo comp-        progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)-        lbi'   = lbi {-                   withPrograms  = progs',-                   withPackageDB = withPackageDB lbi ++ [internalPackageDB]-                 }-    in buildComponent verbosity (buildNumJobs flags) pkg_descr-                      lbi' suffixes comp clbi distPref---repl     :: PackageDescription  -- ^ Mostly information from the .cabal file-         -> LocalBuildInfo      -- ^ Configuration information-         -> ReplFlags           -- ^ Flags that the user passed to build-         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling-         -> [String]-         -> IO ()-repl pkg_descr lbi flags suffixes args = do-  let distPref  = fromFlag (replDistPref flags)-      verbosity = fromFlag (replVerbosity flags)--  targets  <- readBuildTargets pkg_descr args-  targets' <- case targets of-    []       -> return $ take 1 [ componentName c-                                | c <- pkgEnabledComponents pkg_descr ]-    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])-    _        -> die $ "The 'repl' command does not support multiple targets at once."-  let componentsToBuild = componentsInBuildOrder lbi targets'-      componentForRepl  = last componentsToBuild-  debug verbosity $ "Component build order: "-                 ++ intercalate ", "-                      [ showComponentName c | (c,_) <- componentsToBuild ]--  initialBuildSteps distPref pkg_descr lbi verbosity--  internalPackageDB <- createInternalPackageDB verbosity lbi distPref--  let lbiForComponent comp lbi' =-        lbi' {-          withPackageDB = withPackageDB lbi ++ [internalPackageDB],-          withPrograms  = addInternalBuildTools pkg_descr lbi'-                            (componentBuildInfo comp) (withPrograms lbi')-        }--  -- build any dependent components-  sequence_-    [ let comp = getComponent pkg_descr cname-          lbi' = lbiForComponent comp lbi-       in buildComponent verbosity NoFlag-                         pkg_descr lbi' suffixes comp clbi distPref-    | (cname, clbi) <- init componentsToBuild ]--  -- REPL for target components-  let (cname, clbi) = componentForRepl-      comp = getComponent pkg_descr cname-      lbi' = lbiForComponent comp lbi-   in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref----- | Start an interpreter without loading any package files.-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()-startInterpreter verbosity programDb comp packageDBs =-  case compilerFlavor comp of-    GHC   -> GHC.startInterpreter   verbosity programDb comp packageDBs-    GHCJS -> GHCJS.startInterpreter verbosity programDb comp packageDBs-    _     -> die "A REPL is not supported with this compiler."--buildComponent :: Verbosity-               -> Flag (Maybe Int)-               -> PackageDescription-               -> LocalBuildInfo-               -> [PPSuffixHandler]-               -> Component-               -> ComponentLocalBuildInfo-               -> FilePath-               -> IO ()-buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CLib lib) clbi distPref = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    info verbosity "Building library..."-    buildLib verbosity numJobs pkg_descr lbi lib clbi--    -- Register the library in-place, so exes can depend-    -- on internally defined libraries.-    pwd <- getCurrentDirectory-    let -- The in place registration uses the "-inplace" suffix, not an ABI hash-        ipkgid           = inplacePackageId (packageId installedPkgInfo)-        installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr-                                                       ipkgid lib lbi clbi--    registerPackage verbosity-      installedPkgInfo pkg_descr lbi True -- True meaning in place-      (withPackageDB lbi)---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    info verbosity $ "Building executable " ++ exeName exe ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe clbi---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })-               clbi _distPref = do-    let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe clbi---buildComponent verbosity numJobs pkg_descr lbi0 suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09{} })-               clbi -- This ComponentLocalBuildInfo corresponds to a detailed-                    -- test suite and not a real component. It should not-                    -- be used, except to construct the CLBIs for the-                    -- library and stub executable that will actually be-                    -- built.-               distPref = do-    pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =-          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildLib verbosity numJobs pkg lbi lib libClbi-    registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi---buildComponent _ _ _ _ _-               (CTest TestSuite { testInterface = TestSuiteUnsupported tt })-               _ _ =-    die $ "No support for building test suite type " ++ display tt---buildComponent verbosity numJobs pkg_descr lbi suffixes-               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })-               clbi _ = do-    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."-    buildExe verbosity numJobs pkg_descr lbi exe exeClbi---buildComponent _ _ _ _ _-               (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })-               _ _ =-    die $ "No support for building benchmark type " ++ display tt---replComponent :: Verbosity-              -> PackageDescription-              -> LocalBuildInfo-              -> [PPSuffixHandler]-              -> Component-              -> ComponentLocalBuildInfo-              -> FilePath-              -> IO ()-replComponent verbosity pkg_descr lbi suffixes-               comp@(CLib lib) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replLib verbosity pkg_descr lbi lib clbi--replComponent verbosity pkg_descr lbi suffixes-               comp@(CExe exe) clbi _ = do-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe clbi---replComponent verbosity pkg_descr lbi suffixes-               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })-               clbi _distPref = do-    let exe = testSuiteExeV10AsExe test-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe clbi---replComponent verbosity pkg_descr lbi0 suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09{} })-               clbi distPref = do-    pwd <- getCurrentDirectory-    let (pkg, lib, libClbi, lbi, _, _, _) =-          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replLib verbosity pkg lbi lib libClbi---replComponent _ _ _ _-              (CTest TestSuite { testInterface = TestSuiteUnsupported tt })-              _ _ =-    die $ "No support for building test suite type " ++ display tt---replComponent verbosity pkg_descr lbi suffixes-               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })-               clbi _ = do-    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi-    preprocessComponent pkg_descr comp lbi False verbosity suffixes-    replExe verbosity pkg_descr lbi exe exeClbi---replComponent _ _ _ _-              (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })-              _ _ =-    die $ "No support for building benchmark type " ++ display tt--------------------------------------------------------- Shared code for buildComponent and replComponent------- | Translate a exe-style 'TestSuite' component into an exe for building-testSuiteExeV10AsExe :: TestSuite -> Executable-testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =-    Executable {-      exeName    = testName test,-      modulePath = mainFile,-      buildInfo  = testBuildInfo test-    }-testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"---- | Translate a lib-style 'TestSuite' component into a lib + exe for building-testSuiteLibV09AsLibAndExe :: PackageDescription-                           -> TestSuite-                           -> ComponentLocalBuildInfo-                           -> LocalBuildInfo-                           -> FilePath-                           -> FilePath-                           -> (PackageDescription,-                               Library, ComponentLocalBuildInfo,-                               LocalBuildInfo,-                               IPI.InstalledPackageInfo_ ModuleName,-                               Executable, ComponentLocalBuildInfo)-testSuiteLibV09AsLibAndExe pkg_descr-                     test@TestSuite { testInterface = TestSuiteLibV09 _ m }-                     clbi lbi distPref pwd =-    (pkg, lib, libClbi, lbi', ipi, exe, exeClbi)-  where-    bi  = testBuildInfo test-    lib = Library {-            exposedModules = [ m ],-            reexportedModules = [],-            requiredSignatures = [],-            exposedSignatures = [],-            libExposed     = True,-            libBuildInfo   = bi-          }-    libClbi = LibComponentLocalBuildInfo-                { componentPackageDeps = componentPackageDeps clbi-                , componentPackageRenaming = componentPackageRenaming clbi-                , componentLibraries = [LibraryName (testName test)]-                , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]-                }-    pkg = pkg_descr {-            package      = (package pkg_descr) {-                             pkgName = PackageName (testName test)-                           }-          , buildDepends = targetBuildDepends $ testBuildInfo test-          , executables  = []-          , testSuites   = []-          , library      = Just lib-          }-    -- Hack to make the library compile with the right package key.-    -- Probably the "right" way to do this is move this information to-    -- the ComponentLocalBuildInfo, but it seems odd that a single package-    -- can define multiple actual packages.-    lbi' = lbi {-        pkgKey = mkPackageKey (packageKeySupported (compiler lbi))-                              (package pkg) [] []-    }-    ipkgid = inplacePackageId (packageId pkg)-    ipi    = inplaceInstalledPackageInfo pwd distPref pkg ipkgid lib lbi' libClbi-    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),-                           targetBuildRenaming =-                            Map.insert (packageName pkg) defaultRenaming-                                (targetBuildRenaming $ testBuildInfo test)-                         }-          }-    -- | The stub executable needs a new 'ComponentLocalBuildInfo'-    -- that exposes the relevant test suite library.-    exeClbi = ExeComponentLocalBuildInfo {-                componentPackageDeps =-                    (IPI.installedPackageId ipi, packageId ipi)-                  : (filter (\(_, x) -> let PackageName name = pkgName x-                                        in name == "Cabal" || name == "base")-                            (componentPackageDeps clbi)),-                componentPackageRenaming =-                    Map.insert (packageName ipi) defaultRenaming-                               (componentPackageRenaming clbi)-              }-testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"----- | Translate a exe-style 'Benchmark' component into an exe for building-benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo-                     -> (Executable, ComponentLocalBuildInfo)-benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }-                     clbi =-    (exe, exeClbi)-  where-    exe = Executable {-            exeName    = benchmarkName bm,-            modulePath = f,-            buildInfo  = benchmarkBuildInfo bm-          }-    exeClbi = ExeComponentLocalBuildInfo {-                componentPackageDeps = componentPackageDeps clbi,-                componentPackageRenaming = componentPackageRenaming clbi-              }-benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"---- | Initialize a new package db file for libraries defined--- internally to the package.-createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath-                        -> IO PackageDB-createInternalPackageDB verbosity lbi distPref = do-    case compilerFlavor (compiler lbi) of-      GHC   -> createWith $ GHC.hcPkgInfo   (withPrograms lbi)-      GHCJS -> createWith $ GHCJS.hcPkgInfo (withPrograms lbi)-      LHC   -> createWith $ LHC.hcPkgInfo   (withPrograms lbi)-      _     -> return packageDB-    where-      dbPath = distPref </> "package.conf.inplace"-      packageDB = SpecificPackageDB dbPath-      createWith hpi = do-        dir_exists <- doesDirectoryExist dbPath-        if dir_exists-            then removeDirectoryRecursive dbPath-            else do file_exists <- doesFileExist dbPath-                    when file_exists $ removeFile dbPath-        if HcPkg.useSingleFileDb hpi-            then writeFile dbPath "[]"-            else HcPkg.init hpi verbosity dbPath-        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 test suites-buildLib :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity numJobs pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.buildLib   verbosity numJobs pkg_descr lbi lib clbi-    GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi-    JHC   -> JHC.buildLib   verbosity         pkg_descr lbi lib clbi-    LHC   -> LHC.buildLib   verbosity         pkg_descr lbi lib clbi-    UHC   -> UHC.buildLib   verbosity         pkg_descr lbi lib clbi-    HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi-    _    -> die "Building is not supported with this compiler."--buildExe :: Verbosity -> Flag (Maybe Int)-                      -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity numJobs pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.buildExe   verbosity numJobs pkg_descr lbi exe clbi-    GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi-    JHC   -> JHC.buildExe   verbosity         pkg_descr lbi exe clbi-    LHC   -> LHC.buildExe   verbosity         pkg_descr lbi exe clbi-    UHC   -> UHC.buildExe   verbosity         pkg_descr lbi exe clbi-    _     -> die "Building is not supported with this compiler."--replLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                     -> Library            -> ComponentLocalBuildInfo -> IO ()-replLib verbosity pkg_descr lbi lib clbi =-  case compilerFlavor (compiler lbi) of-    -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass-    -- NoFlag as the numJobs parameter.-    GHC   -> GHC.replLib   verbosity NoFlag pkg_descr lbi lib clbi-    GHCJS -> GHCJS.replLib verbosity NoFlag pkg_descr lbi lib clbi-    _     -> die "A REPL is not supported for this compiler."--replExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                     -> Executable         -> ComponentLocalBuildInfo -> IO ()-replExe verbosity pkg_descr lbi exe clbi =-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.replExe   verbosity NoFlag pkg_descr lbi exe clbi-    GHCJS -> GHCJS.replExe verbosity NoFlag pkg_descr lbi exe clbi-    _     -> die "A REPL is not supported for 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)---- | Check that the given build targets are valid in the current context.------ Also swizzle into a more convenient form.----checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]-                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]-checkBuildTargets _ pkg []      =-    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]--checkBuildTargets verbosity pkg targets = do--    let (enabled, disabled) =-          partitionEithers-            [ case componentDisabledReason (getComponent pkg cname) of-                Nothing     -> Left  target'-                Just reason -> Right (cname, reason)-            | target <- targets-            , let target'@(cname,_) = swizzleTarget target ]--    case disabled of-      []                 -> return ()-      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason--    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->-      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "-                    ++ showComponentName c ++ " will be built. (Support for "-                    ++ "module and file targets has not been implemented yet.)"--    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 build the " ++ cn ++ " because the component is marked "-     ++ "as disabled in the .cabal file."-    formatReason cn DisabledAllTests =-        "Cannot build the " ++ cn ++ " because test suites are not "-     ++ "enabled. Run configure with the flag --enable-tests"-    formatReason cn DisabledAllBenchmarks =-        "Cannot build the " ++ cn ++ " because benchmarks are not "-     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
− Distribution/Simple/Build/Macros.hs 
@@ -1,109 +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,-    generatePackageVersionMacros,-  ) where--import Data.Maybe-         ( isJust )-import Distribution.Package-         ( PackageIdentifier(PackageIdentifier) )-import Distribution.Version-         ( Version(versionBranch) )-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.Simple.Compiler-         ( packageKeySupported )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(compiler, pkgKey, withPrograms), externalPackageDeps )-import Distribution.Simple.Program.Db-         ( configuredPrograms )-import Distribution.Simple.Program.Types-         ( ConfiguredProgram(programId, programVersion) )-import Distribution.Text-         ( display )---- --------------------------------------------------------------- * Generate cabal_macros.h--- ---------------------------------------------------------------- | The contents of the @cabal_macros.h@ for the given configured package.----generate :: PackageDescription -> LocalBuildInfo -> String-generate _pkg_descr lbi =-  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" ++-  generatePackageVersionMacros (map snd (externalPackageDeps lbi)) ++-  generateToolVersionMacros (configuredPrograms . withPrograms $ lbi) ++-  generatePackageKeyMacro lbi---- | 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 :: [PackageIdentifier] -> String-generatePackageVersionMacros pkgids = concat-  [ "/* package " ++ display pkgid ++ " */\n"-  ++ generateMacros "" pkgname version-  | pkgid@(PackageIdentifier name version) <- pkgids-  , let pkgname = map fixchar (display name)-  ]---- | Helper function that generates just the @TOOL_VERSION_pkg@ and--- @MIN_TOOL_VERSION_pkg@ macros for a list of configured programs.----generateToolVersionMacros :: [ConfiguredProgram] -> String-generateToolVersionMacros progs = concat-  [ "/* tool " ++ progid ++ " */\n"-  ++ generateMacros "TOOL_" progname version-  | prog <- progs-  , isJust . programVersion $ prog-  , let progid       = programId prog ++ "-" ++ display version-        progname     = map fixchar (programId prog)-        Just version = programVersion prog-  ]---- | Common implementation of 'generatePackageVersionMacros' and--- 'generateToolVersionMacros'.----generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (display version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)---- | Generate the @CURRENT_PACKAGE_KEY@ definition for the package key---   of the current package, if supported by the compiler-generatePackageKeyMacro :: LocalBuildInfo -> String-generatePackageKeyMacro lbi-  | packageKeySupported (compiler lbi) =-      "#define CURRENT_PACKAGE_KEY \"" ++ display (pkgKey lbi) ++ "\"\n\n"-  | otherwise = ""--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c
− Distribution/Simple/Build/PathsModule.hs 
@@ -1,303 +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, Arch(..), buildArch )-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.Simple.Utils-         ( shortRelativePath )-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 = ""-        | supports_language_pragma =-          "{-# LANGUAGE ForeignFunctionInterface #-}\n"-        | otherwise =-          "{-# OPTIONS_GHC -fffi #-}\n"++-          "{-# OPTIONS_JHC -fffi #-}\n"--       foreign_imports-        | absolute = ""-        | otherwise =-          "import Foreign\n"++-          "import Foreign.C\n"--       reloc_imports-        | reloc =-          "import System.Environment (getExecutablePath)\n"-        | otherwise = ""--       header =-        pragmas++-        "module " ++ display paths_modulename ++ " (\n"++-        "    version,\n"++-        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++-        "    getDataFileName, getSysconfDir\n"++-        "  ) where\n"++-        "\n"++-        foreign_imports++-        "import qualified Control.Exception as Exception\n"++-        "import Data.Version (Version(..))\n"++-        "import System.Environment (getEnv)\n"++-        reloc_imports ++-        "import Prelude\n"++-        "\n"++-        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++-        "catchIO = Exception.catch\n" ++-        "\n"++-        "version :: Version"++-        "\nversion = Version " ++ show branch ++ " " ++ show tags-          where Version branch tags = packageVersion pkg_descr--       body-        | reloc =-          "\n\nbindirrel :: FilePath\n" ++-          "bindirrel = " ++ show flat_bindirreloc ++-          "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++-          "getBinDir = "++mkGetEnvOrReloc "bindir" flat_bindirreloc++"\n"++-          "getLibDir = "++mkGetEnvOrReloc "libdir" flat_libdirreloc++"\n"++-          "getDataDir = "++mkGetEnvOrReloc "datadir" flat_datadirreloc++"\n"++-          "getLibexecDir = "++mkGetEnvOrReloc "libexecdir" flat_libexecdirreloc++"\n"++-          "getSysconfDir = "++mkGetEnvOrReloc "sysconfdir" flat_sysconfdirreloc++"\n"++-          "\n"++-          "getDataFileName :: FilePath -> IO FilePath\n"++-          "getDataFileName name = do\n"++-          "  dir <- getDataDir\n"++-          "  return (dir `joinFileName` name)\n"++-          "\n"++-          get_prefix_reloc_stuff++-          "\n"++-          filename_stuff-        | absolute =-          "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++-          "\nbindir     = " ++ show flat_bindir ++-          "\nlibdir     = " ++ show flat_libdir ++-          "\ndatadir    = " ++ show flat_datadir ++-          "\nlibexecdir = " ++ show flat_libexecdir ++-          "\nsysconfdir = " ++ show flat_sysconfdir ++-          "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: 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"++-          "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\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"++-          "getSysconfDir :: IO FilePath\n"++-          "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\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,-          sysconfdir = flat_sysconfdir-        } = absoluteInstallDirs pkg_descr lbi NoCopyDest-        InstallDirs {-          bindir     = flat_bindirrel,-          libdir     = flat_libdirrel,-          datadir    = flat_datadirrel,-          libexecdir = flat_libexecdirrel,-          sysconfdir = flat_sysconfdirrel-        } = prefixRelativeInstallDirs (packageId pkg_descr) lbi--        flat_bindirreloc = shortRelativePath flat_prefix flat_bindir-        flat_libdirreloc = shortRelativePath flat_prefix flat_libdir-        flat_datadirreloc = shortRelativePath flat_prefix flat_datadir-        flat_libexecdirreloc = shortRelativePath flat_prefix flat_libexecdir-        flat_sysconfdirreloc = shortRelativePath flat_prefix flat_sysconfdir--        mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel-        mkGetDir dir Nothing       = "return " ++ show dir--        mkGetEnvOrReloc var dirrel = "catchIO (getEnv \""++var'++"\")" ++-                                     " (\\_ -> getPrefixDirReloc \"" ++ dirrel ++-                                     "\")"-          where var' = pkgPathEnvVar pkg_descr var--        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-          || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))--        reloc = relocatable lbi--        supportsRelocatableProgs GHC  = case buildOS of-                           Windows   -> True-                           _         -> False-        supportsRelocatableProgs GHCJS = case buildOS of-                           Windows   -> True-                           _         -> False-        supportsRelocatableProgs _    = False--        paths_modulename = autogenModuleName pkg_descr--        get_prefix_stuff = get_prefix_win32 buildArch--        path_sep = show [pathSeparator]--        supports_language_pragma =-          (compilerFlavor (compiler lbi) == GHC &&-            (compilerVersion (compiler lbi)-              `withinRange` orLaterVersion (Version [6,6,1] []))) ||-           compilerFlavor (compiler lbi) == GHCJS---- | Generates the name of the environment variable controlling the path--- component of interest.-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-    where-        showPkgName = map fixchar . display-        fixchar '-' = '_'-        fixchar c   = c--get_prefix_reloc_stuff :: String-get_prefix_reloc_stuff =-  "getPrefixDirReloc :: FilePath -> IO FilePath\n"++-  "getPrefixDirReloc dirRel = do\n"++-  "  exePath <- getExecutablePath\n"++-  "  let (bindir,_) = splitFileName exePath\n"++-  "  return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"--get_prefix_win32 :: Arch -> String-get_prefix_win32 arch =-  "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 " ++ cconv ++ " unsafe \"windows.h GetModuleFileNameW\"\n"++-  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"-    where cconv = case arch of-                  I386 -> "stdcall"-                  X86_64 -> "ccall"-                  _ -> error "win32 supported only with I386, X86_64"--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,121 +0,0 @@--------------------------------------------------------------------------------- |--- 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,-    hscolourPref, haddockPref,-    autogenModulesDir,--    autogenModuleName,-    cppHeaderName,-    haddockName,--    mkLibName,-    mkProfLibName,-    mkSharedLibName,--    exeExtension,-    objExtension,-    dllExtension,--  ) where---import System.FilePath ((</>), (<.>))--import Distribution.Package-         ( 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), LibraryName(..) )-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 :: LibraryName -> String-mkLibName (LibraryName lib) = "lib" ++ lib <.> "a"--mkProfLibName :: LibraryName -> String-mkProfLibName (LibraryName lib) =  "lib" ++ 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 :: CompilerId -> LibraryName -> String-mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)-  = "lib" ++ 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 the extension is @\"o\"@.-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/BuildTarget.hs 
@@ -1,939 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- 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 (--    -- * Build targets-    BuildTarget(..),-    readBuildTargets,--    -- * Parsing user build targets-    UserBuildTarget,-    readUserBuildTargets,-    UserBuildTargetProblem(..),-    reportUserBuildTargetProblems,--    -- * Resolving build targets-    resolveBuildTargets,-    BuildTargetProblem(..),-    reportBuildTargetProblems,-  ) where--import Distribution.Package-         ( Package(..), PackageId, packageName )--import Distribution.PackageDescription-         ( PackageDescription-         , Executable(..)-         , TestSuite(..), TestSuiteInterface(..), testModules-         , Benchmark(..), BenchmarkInterface(..), benchmarkModules-         , BuildInfo(..), libModules, exeModules )-import Distribution.ModuleName-         ( ModuleName, toFilePath )-import Distribution.Simple.LocalBuildInfo-         ( Component(..), ComponentName(..)-         , pkgComponents, componentName, componentBuildInfo )--import Distribution.Text-         ( display )-import Distribution.Simple.Utils-         ( die, lowercase, equating )--import Data.List-         ( nub, stripPrefix, sortBy, groupBy, partition, intercalate )-import Data.Ord-import Data.Maybe-         ( listToMaybe, catMaybes )-import Data.Either-         ( partitionEithers )-import qualified Data.Map as Map-import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..))-#endif-import Control.Applicative (Alternative(..))-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Compat.ReadP-         ( (+++), (<++) )-import Data.Char-         ( isSpace, isAlphaNum )-import System.FilePath as FilePath-         ( dropExtension, normalise, splitDirectories, joinPath, splitPath-         , hasTrailingPathSeparator )-import System.Directory-         ( doesFileExist, doesDirectoryExist )---- --------------------------------------------------------------- * 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 (Show,Eq)----- --------------------------------------------------------------- * Do everything--- --------------------------------------------------------------readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]-readBuildTargets pkg targetStrs = do-    let (uproblems, utargets) = readUserBuildTargets targetStrs-    reportUserBuildTargetProblems uproblems--    utargets' <- mapM checkTargetExistsAsFile utargets--    let (bproblems, btargets) = resolveBuildTargets pkg utargets'-    reportBuildTargetProblems 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 :: String -> Either UserBuildTargetProblem-                                        UserBuildTarget-readUserBuildTarget targetstr =-    case readPToMaybe parseTargetApprox targetstr of-      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)-      Just tgt -> Right tgt--  where-    parseTargetApprox :: Parse.ReadP r UserBuildTarget-    parseTargetApprox =-          (do a <- tokenQ-              return (UserBuildTargetSingle a))-      +++ (do a <- token-              _ <- Parse.char ':'-              b <- tokenQ-              return (UserBuildTargetDouble a b))-      +++ (do a <- token-              _ <- Parse.char ':'-              b <- token-              _ <- Parse.char ':'-              c <- tokenQ-              return (UserBuildTargetTriple a b c))--    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')-    tokenQ = parseHaskellString <++ token-    parseHaskellString :: Parse.ReadP r String-    parseHaskellString = Parse.readS_to_P reads--    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                         , all isSpace s ]--data UserBuildTargetProblem-   = UserBuildTargetUnrecognised String-  deriving Show--reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()-reportUserBuildTargetProblems problems = do-    case [ target | UserBuildTargetUnrecognised target <- problems ] of-      []     -> return ()-      target ->-        die $ unlines-                [ "Unrecognised build target '" ++ name ++ "'."-                | name <- target ]-           ++ "Examples:\n"-           ++ " - build foo          -- component name "-           ++ "(library, executable, test-suite or benchmark)\n"-           ++ " - build Data.Foo     -- module name\n"-           ++ " - build Data/Foo.hsc -- file name\n"-           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"-           ++ " - build foo:Data.Foo      -- module qualified by component\n"-           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"--showUserBuildTarget :: UserBuildTarget -> String-showUserBuildTarget = intercalate ":" . components-  where-    components (UserBuildTargetSingle s1)       = [s1]-    components (UserBuildTargetDouble s1 s2)    = [s1,s2]-    components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]----- --------------------------------------------------------------- * 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 (BuildTargetAmbigious userTarget targets')-                               where targets' = disambiguateBuildTargets-                                                    (packageId pkg) userTarget-                                                    targets-      None        errs    -> Left (classifyMatchErrors errs)--  where-    classifyMatchErrors errs-      | not (null expected) = let (things, got:_) = unzip expected in-                              BuildTargetExpected userTarget things got-      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch-      | otherwise = error $ "resolveBuildTarget: internal error in matching"-      where-        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]-        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]---data BuildTargetProblem-   = BuildTargetExpected  UserBuildTarget [String]  String-     -- ^  [expected thing] (actually got)-   | BuildTargetNoSuch    UserBuildTarget [(String, String)]-     -- ^ [(no such thing,  actually got)]-   | BuildTargetAmbigious 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) = display m-    single (BuildTargetFile      _  f) = f--    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)-    double (BuildTargetModule    cn m) = (dispCName cn, display m)-    double (BuildTargetFile      cn f) = (dispCName cn, f)--    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"-    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)-    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)--    dispCName = componentStringName pkgid-    dispKind  = showComponentKindShort . componentKind--reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()-reportBuildTargetProblems problems = do--    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [    "Unrecognised build target '" ++ showUserBuildTarget target-            ++ "'.\n"-            ++ "Expected a " ++ intercalate " or " expected-            ++ ", rather than '" ++ got ++ "'."-          | (target, expected, got) <- targets ]--    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [    "Unknown build target '" ++ showUserBuildTarget target-            ++ "'.\nThere is no "-            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"-                                  | (thing, got) <- nosuch ] ++ "."-          | (target, nosuch) <- targets ]-        where-          mungeThing "file" = "file target"-          mungeThing thing  = thing--    case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of-      []      -> return ()-      targets ->-        die $ unlines-          [    "Ambiguous build target '" ++ showUserBuildTarget target-            ++ "'. It could be:\n "-            ++ unlines [ "   "++ showUserBuildTarget ut ++-                         " (" ++ showBuildTargetKind bt ++ ")"-                       | (ut, bt) <- amb ]-          | (target, amb) <- targets ]--  where-    showBuildTargetKind (BuildTargetComponent _  ) = "component"-    showBuildTargetKind (BuildTargetModule    _ _) = "module"-    showBuildTargetKind (BuildTargetFile      _ _) = "file"---------------------------------------- Top level BuildTarget matcher-----matchBuildTarget :: PackageDescription-                 -> UserBuildTarget -> Bool -> Match BuildTarget-matchBuildTarget pkg = \utarget fexists ->-    case utarget of-      UserBuildTargetSingle str1 ->-        matchBuildTarget1 cinfo str1 fexists--      UserBuildTargetDouble str1 str2 ->-        matchBuildTarget2 cinfo str1 str2 fexists--      UserBuildTargetTriple str1 str2 str3 ->-        matchBuildTarget3 cinfo str1 str2 str3 fexists-  where-    cinfo = pkgComponentInfo pkg--matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget-matchBuildTarget1 cinfo str1 fexists =-                        matchComponent1 cinfo str1-   `matchPlusShadowing` matchModule1    cinfo str1-   `matchPlusShadowing` matchFile1      cinfo str1 fexists---matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool-                  -> Match BuildTarget-matchBuildTarget2 cinfo str1 str2 fexists =-                        matchComponent2 cinfo str1 str2-   `matchPlusShadowing` matchModule2    cinfo str1 str2-   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists---matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool-                  -> Match BuildTarget-matchBuildTarget3 cinfo str1 str2 str3 fexists =-                        matchModule3    cinfo str1 str2 str3-   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists---data ComponentInfo = ComponentInfo {-       cinfoName    :: ComponentName,-       cinfoStrName :: ComponentStringName,-       cinfoSrcDirs :: [FilePath],-       cinfoModules :: [ModuleName],-       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)-       cinfoCFiles  :: [FilePath],-       cinfoJsFiles :: [FilePath]-     }--type ComponentStringName = String--pkgComponentInfo :: PackageDescription -> [ComponentInfo]-pkgComponentInfo pkg =-    [ ComponentInfo {-        cinfoName    = componentName c,-        cinfoStrName = componentStringName pkg (componentName c),-        cinfoSrcDirs = hsSourceDirs bi,-        cinfoModules = componentModules c,-        cinfoHsFiles = componentHsFiles c,-        cinfoCFiles  = cSources bi,-        cinfoJsFiles = jsSources bi-      }-    | c <- pkgComponents pkg-    , let bi = componentBuildInfo c ]--componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName-componentStringName pkg CLibName          = display (packageName pkg)-componentStringName _   (CExeName  name)  = name-componentStringName _   (CTestName  name) = name-componentStringName _   (CBenchName name) = name--componentModules :: Component -> [ModuleName]-componentModules (CLib   lib)   = libModules lib-componentModules (CExe   exe)   = exeModules exe-componentModules (CTest  test)  = testModules test-componentModules (CBench bench) = benchmarkModules bench--componentHsFiles :: Component -> [FilePath]-componentHsFiles (CExe exe) = [modulePath exe]-componentHsFiles (CTest  TestSuite {-                           testInterface = TestSuiteExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles (CBench Benchmark {-                           benchmarkInterface = BenchmarkExeV10 _ mainfile-                         }) = [mainfile]-componentHsFiles _          = []--{--ex_cs :: [ComponentInfo]-ex_cs =-  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])-  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])-  ]-    where-    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)-    mkMn :: String -> ModuleName-    mkMn  = fromJust . simpleParse-    pkgid :: PackageIdentifier-    Just pkgid = simpleParse "thelib"--}----------------------------------- Matching component kinds-----data ComponentKind = LibKind | ExeKind | TestKind | BenchKind-  deriving (Eq, Ord, Show)--componentKind :: ComponentName -> ComponentKind-componentKind CLibName       = LibKind-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"]            = increaseConfidence >> return LibKind-  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind-  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence-                                             >> return TestKind-  | s `elem` ["bench", "benchmark"]        = increaseConfidence-                                             >> return BenchKind-  | otherwise                              = matchErrorExpected-                                             "component kind" s--showComponentKind :: ComponentKind -> String-showComponentKind LibKind   = "library"-showComponentKind ExeKind   = "executable"-showComponentKind TestKind  = "test-suite"-showComponentKind BenchKind = "benchmark"--showComponentKindShort :: ComponentKind -> String-showComponentKindShort LibKind   = "lib"-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-      [ (display 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 ambigious matches.------ There are various matcher primitives ('matchExactly', 'matchInexactly'),--- ways to combine matchers ('ambigiousWith', '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--- ambigious 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 'ambigiousWith' 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 = return-  (<*>) = ap--instance Monad Match where-  return a                = ExactMatch 0 [a]-  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 -> MaybeAmbigious b-findMatch match =-    case match of-      NoMatch    _ msgs -> None (nub msgs)-      ExactMatch   _ xs -> checkAmbigious xs-      InexactMatch _ xs -> checkAmbigious xs-  where-    checkAmbigious xs = case nub xs of-                          [x] -> Unambiguous x-                          xs' -> Ambiguous   xs'--data MaybeAmbigious 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
− Distribution/Simple/CCompiler.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.CCompiler--- Copyright   :  2011, Dan Knapp------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This simple package provides types and functions for interacting with--- C compilers.  Currently it's just a type enumerating extant C-like--- languages, which we call dialects.--{--Redistribution and use in source and binary forms, with or without-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 (-   CDialect(..),-   cSourceExtensions,-   cDialectFilenameExtension,-   filenameCDialect-  ) where--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-     ( Monoid(..) )-#endif-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 C                  anything           = anything-  mappend ObjectiveC         CPlusPlus          = ObjectiveCPlusPlus-  mappend CPlusPlus          ObjectiveC         = ObjectiveCPlusPlus-  mappend _                  ObjectiveCPlusPlus = ObjectiveCPlusPlus-  mappend ObjectiveC         _                  = ObjectiveC-  mappend CPlusPlus          _                  = CPlusPlus-  mappend 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
− Distribution/Simple/Command.hs 
@@ -1,600 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Command--- Copyright   :  Duncan Coutts 2007--- License     :  BSD3------ 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@.--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,--  -- ** 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-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif-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 )-import Text.PrettyPrint as PP ( 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,-    -- | A function that maps a program name to a usage summary for this-    -- command.-    commandUsage    :: String -> String,-    -- | Additional explanation of the command to use in help texts.-    commandDescription :: Maybe (String -> String),-    -- | Post-Usage notes and examples in help texts-    commandNotes :: Maybe (String -> String),-    -- | Initial \/ empty flags-    commandDefaultFlags :: flags,-    -- | All the Option fields for this command-    commandOptions     :: ShowOrParseArgs -> [OptionField flags]-  }--data 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)) (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) ([],  [])  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) ]---- | 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--      cmp :: OptDescr a -> OptDescr a -> Ordering-      ReqArg{}    `cmp` ReqArg{}    = EQ-      ReqArg{}    `cmp` _           = GT-      BoolOpt{}   `cmp` ReqArg{}    = LT-      BoolOpt{}   `cmp` BoolOpt{}   = EQ-      BoolOpt{}   `cmp` _           = GT-      ChoiceOpt{} `cmp` ReqArg{}    = LT-      ChoiceOpt{} `cmp` BoolOpt{}   = LT-      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ-      ChoiceOpt{} `cmp` _           = GT-      OptArg{}    `cmp` OptArg{}    = EQ-      OptArg{}    `cmp` _           = LT----    get :: a -> Doc-      get t = case optDescr of-        ReqArg _ _ _ _ ppr ->-          (cat . punctuate comma . map text . ppr) t--        OptArg _ _ _ _ _ ppr ->-          case ppr t of []        -> PP.empty-                        (Nothing : _) -> text "True"-                        (Just a  : _) -> text a--        ChoiceOpt alts ->-          fromMaybe PP.empty $ listToMaybe-          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]--        BoolOpt _ _ _ _ enabled -> (maybe PP.empty disp . enabled) t----    set :: LineNo -> String -> a -> ParseResult a-      set line val a =-        case optDescr of-          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val-                                     -- We parse for a single value instead of a-                                     -- list, as one can't really implement-                                     -- parseList :: ReadE a -> ReadE [a] with-                                     -- the current ReadE definition-          ChoiceOpt{}             ->-            case getChoiceByLongFlag optDescr val of-              Just f -> return (f a)-              _      -> syntaxError line val--          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runP line n parse val--          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val-                                     -- Optional arguments are parsed just like-                                     -- required arguments here; we don't-                                     -- provide a method to set an OptArg field-                                     -- to the default value.--getChoiceByLongFlag :: OptDescr 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-    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 (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 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 synopsys f _cmdType) =-  Command name synopsys 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--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 _ _ NormalCommand) <- commands' ]--    -- A bit of a hack: support "prog help" as a synonym of "prog --help"-    -- furthermore, support "prog help command" as "prog command --help"-    handleHelpCommand cmdArgs =-      case commandParseArgs helpCommandUI True cmdArgs of-        CommandHelp      help    -> CommandHelp help-        CommandList      list    -> CommandList (list ++ commandNames)-        CommandErrors    _       -> CommandHelp globalHelp-        CommandReadyToGo (_,[])  -> CommandHelp globalHelp-        CommandReadyToGo (_,(name:cmdArgs')) ->-          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---- | 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]---- | 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 [])
− Distribution/Simple/Compiler.hs 
@@ -1,287 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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 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.--module Distribution.Simple.Compiler (-        -- * Haskell implementations-        module Distribution.Compiler,-        Compiler(..),-        showCompilerId, showCompilerIdWithAbi,-        compilerFlavor, compilerVersion,-        compilerCompatVersion,-        compilerInfo,--        -- * Support for package databases-        PackageDB(..),-        PackageDBStack,-        registrationPackageDB,-        absolutePackageDBPaths,-        absolutePackageDBPath,--        -- * Support for optimisation levels-        OptimisationLevel(..),-        flagToOptimisationLevel,--        -- * Support for debug info levels-        DebugInfoLevel(..),-        flagToDebugInfoLevel,--        -- * Support for language extensions-        Flag,-        languageToFlags,-        unsupportedLanguages,-        extensionsToFlags,-        unsupportedExtensions,-        parmakeSupported,-        reexportedModulesSupported,-        renamingPackageFlagsSupported,-        packageKeySupported-  ) where--import Distribution.Compiler-import Distribution.Version (Version(..))-import Distribution.Text (display)-import Language.Haskell.Extension (Language(Haskell98), Extension)--import Control.Monad (liftM)-import Distribution.Compat.Binary (Binary)-import Data.List (nub)-import qualified Data.Map as M (Map, lookup)-import Data.Maybe (catMaybes, isNothing, listToMaybe)-import GHC.Generics (Generic)-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, Flag)],-        -- ^ Supported language standards.-        compilerExtensions      :: [(Extension, Flag)],-        -- ^ Supported extensions.-        compilerProperties      :: M.Map String String-        -- ^ A key-value map for properties not covered by the above fields.-    }-    deriving (Generic, Show, Read)--instance Binary Compiler--showCompilerId :: Compiler -> String-showCompilerId = display . compilerId--showCompilerIdWithAbi :: Compiler -> String-showCompilerIdWithAbi comp =-  display (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--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 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, Generic, Ord, Show, Read)--instance Binary PackageDB---- | 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---- | Make package paths absolute---absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack-absolutePackageDBPaths = mapM absolutePackageDBPath--absolutePackageDBPath :: PackageDB -> IO PackageDB-absolutePackageDBPath GlobalPackageDB        = return GlobalPackageDB-absolutePackageDBPath UserPackageDB          = return UserPackageDB-absolutePackageDBPath (SpecificPackageDB db) =-  SpecificPackageDB `liftM` canonicalizePath db---- --------------------------------------------------------------- * Optimisation levels--- ---------------------------------------------------------------- | Some compilers support optimising. Some have different levels.--- For compilers that do not the level is just capped to the level--- they do support.----data OptimisationLevel = NoOptimisation-                       | NormalOptimisation-                       | MaximumOptimisation-    deriving (Bounded, Enum, Eq, Generic, Read, Show)--instance Binary 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--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 -> [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)---- | 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 support package keys?-packageKeySupported :: Compiler -> Bool-packageKeySupported = ghcSupported "Uses package keys"---- | 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 M.lookup key (compilerProperties comp) of-            Just "YES" -> True-            _          -> False
− Distribution/Simple/Configure.hs 
@@ -1,1674 +0,0 @@-{-# LANGUAGE CPP                #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RecordWildCards    #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Configure--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This deals with the /configure/ phase. It provides the 'configure' action--- which is given the package description and configure flags. It then tries--- to: configure the compiler; resolves any conditionals in the package--- description; resolve the package dependencies; check if all the extensions--- used by this package are supported by the compiler; check that all the build--- tools are available (including version checks if appropriate); checks for--- any required @pkg-config@ packages (updating the 'BuildInfo' with the--- results)------ Then based on all this it saves the info in the 'LocalBuildInfo' and writes--- it out to the @dist\/setup-config@ file. It also displays various details to--- the user, the amount of information displayed depending on the verbosity--- level.--module Distribution.Simple.Configure (configure,-                                      writePersistBuildConfig,-                                      getConfigStateFile,-                                      getPersistBuildConfig,-                                      checkPersistBuildConfigOutdated,-                                      tryGetPersistBuildConfig,-                                      maybeGetPersistBuildConfig,-                                      localBuildInfoFile,-                                      getInstalledPackages, getPackageDBContents,-                                      configCompiler, configCompilerAux,-                                      configCompilerEx, configCompilerAuxEx,-                                      ccLdOptionsBuildInfo,-                                      checkForeignDeps,-                                      interpretPackageDbFlags,-                                      ConfigStateFileError(..),-                                      tryGetConfigStateFile,-                                      platformDefines,-                                     )-    where--import Distribution.Compiler-    ( CompilerId(..) )-import Distribution.Utils.NubList-import Distribution.Simple.Compiler-    ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion-    , compilerInfo-    , showCompilerId, unsupportedLanguages, unsupportedExtensions-    , PackageDB(..), PackageDBStack, reexportedModulesSupported-    , packageKeySupported, renamingPackageFlagsSupported )-import Distribution.Simple.PreProcess ( platformDefines )-import Distribution.Package-    ( PackageName(PackageName), PackageIdentifier(..), PackageId-    , packageName, packageVersion, Package(..)-    , Dependency(Dependency), simplifyDependency-    , InstalledPackageId(..), thisPackageVersion-    , mkPackageKey, PackageKey(..), packageKeyLibraryName )-import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.InstalledPackageInfo (InstalledPackageInfo, emptyInstalledPackageInfo)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import Distribution.PackageDescription as PD-    ( PackageDescription(..), specVersion, GenericPackageDescription(..)-    , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions-    , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..)-    , ModuleReexport(..) , defaultRenaming )-import Distribution.ModuleName-    ( ModuleName )-import Distribution.PackageDescription.Configuration-    ( finalizePackageDescription, mapTreeData )-import Distribution.PackageDescription.Check-    ( PackageCheck(..), checkPackage, checkPackageFiles )-import Distribution.Simple.Program-    ( Program(..), ProgramLocation(..), ConfiguredProgram(..)-    , ProgramConfiguration, defaultProgramConfiguration-    , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath-    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram-    , userSpecifyArgss, userSpecifyPaths-    , lookupProgram, requireProgram, requireProgramVersion-    , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )-import Distribution.Simple.Setup-    ( ConfigFlags(..), CopyDest(..), Flag(..), fromFlag, fromFlagOrDefault-    , flagToMaybe )-import Distribution.Simple.InstallDirs-    ( InstallDirs(..), defaultInstallDirs, combineInstallDirs )-import Distribution.Simple.LocalBuildInfo-    ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-    , LibraryName(..)-    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId-    , ComponentName(..), showComponentName, pkgEnabledComponents-    , componentBuildInfo, componentName, checkComponentsCyclic )-import Distribution.Simple.BuildPaths-    ( autogenModulesDir )-import Distribution.Simple.Utils-    ( die, warn, info, setupMessage-    , createDirectoryIfMissingVerbose, moreRecentFile-    , intercalate, cabalVersion-    , writeFileAtomic-    , withTempFile )-import Distribution.System-    ( OS(..), buildOS, Platform (..), 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.GHCJS as GHCJS-import qualified Distribution.Simple.JHC   as JHC-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite---- Prefer the more generic Data.Traversable.mapM to Prelude.mapM-import Prelude hiding ( mapM )-import Control.Exception-    ( ErrorCall(..), Exception, evaluate, throw, throwIO, try )-import Control.Monad-    ( liftM, when, unless, foldM, filterM )-import Distribution.Compat.Binary ( decodeOrFailIO, encode )-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.List-    ( (\\), nub, partition, isPrefixOf, inits, stripPrefix )-import Data.Maybe-    ( isNothing, catMaybes, fromMaybe, isJust )-import Data.Either-    ( partitionEithers )-import qualified Data.Set as Set-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-    ( Monoid(..) )-#endif-import qualified Data.Map as Map-import Data.Map (Map)-import Data.Traversable-    ( mapM )-import Data.Typeable-import System.Directory-    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )-import System.FilePath-    ( (</>), isAbsolute )-import qualified System.Info-    ( compilerName, compilerVersion )-import System.IO-    ( hPutStrLn, hClose )-import Distribution.Text-    ( Text(disp), display, simpleParse )-import Text.PrettyPrint-    ( render, (<>), ($+$), char, text, comma-    , quotes, punctuate, nest, sep, hsep )-import Distribution.Compat.Exception ( catchExit, catchIO )--data ConfigStateFileError-    = ConfigStateFileNoHeader-    | ConfigStateFileBadHeader-    | ConfigStateFileNoParse-    | ConfigStateFileMissing-    | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)-  deriving (Typeable)--instance Show ConfigStateFileError where-    show ConfigStateFileNoHeader =-        "Saved package config file header is missing. "-        ++ "Try re-running the 'configure' command."-    show ConfigStateFileBadHeader =-        "Saved package config file header is corrupt. "-        ++ "Try re-running the 'configure' command."-    show ConfigStateFileNoParse =-        "Saved package config file body is corrupt. "-        ++ "Try re-running the 'configure' command."-    show ConfigStateFileMissing = "Run the 'configure' command first."-    show (ConfigStateFileBadVersion oldCabal oldCompiler _) =-        "You need to re-run the 'configure' command. "-        ++ "The version of Cabal being used has changed (was "-        ++ display oldCabal ++ ", now "-        ++ display currentCabalId ++ ")."-        ++ badCompiler-      where-        badCompiler-          | oldCompiler == currentCompilerId = ""-          | otherwise =-              " Additionally the compiler is different (was "-              ++ display oldCompiler ++ ", now "-              ++ display currentCompilerId-              ++ ") which is probably the cause of the problem."--instance Exception ConfigStateFileError--getConfigStateFile :: FilePath -> IO LocalBuildInfo-getConfigStateFile filename = do-    exists <- doesFileExist filename-    unless exists $ throwIO ConfigStateFileMissing-    -- Read the config file into a strict ByteString to avoid problems with-    -- lazy I/O, then convert to lazy because the binary package needs that.-    contents <- BS.readFile filename-    let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])--    headerParseResult <- try $ evaluate $ parseHeader header-    let (cabalId, compId) =-            case headerParseResult of-              Left (ErrorCall _) -> throw ConfigStateFileBadHeader-              Right x -> x--    let getStoredValue = do-          result <- decodeOrFailIO (BLC8.tail body)-          case result of-            Left _ -> throw ConfigStateFileNoParse-            Right x -> return x-        deferErrorIfBadVersion act-          | cabalId /= currentCabalId = do-              eResult <- try act-              throw $ ConfigStateFileBadVersion cabalId compId eResult-          | otherwise = act-    deferErrorIfBadVersion getStoredValue--tryGetConfigStateFile :: FilePath-                      -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetConfigStateFile = try . getConfigStateFile---- |Try to read the 'localBuildInfoFile'.-tryGetPersistBuildConfig :: FilePath-                         -> IO (Either ConfigStateFileError LocalBuildInfo)-tryGetPersistBuildConfig = try . getPersistBuildConfig---- | Read the 'localBuildInfoFile'. Throw an exception if the file is--- missing, if the file cannot be read, or if the file was created by an older--- version of Cabal.-getPersistBuildConfig :: FilePath -> IO LocalBuildInfo-getPersistBuildConfig = getConfigStateFile . localBuildInfoFile---- |Try to read the 'localBuildInfoFile'.-maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)-maybeGetPersistBuildConfig =-    liftM (either (const Nothing) Just) . tryGetPersistBuildConfig---- |After running configure, output the 'LocalBuildInfo' to the--- 'localBuildInfoFile'.-writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()-writePersistBuildConfig distPref lbi = do-    createDirectoryIfMissing False distPref-    writeFileAtomic (localBuildInfoFile distPref) $-      BLC8.unlines [showHeader pkgId, encode lbi]-  where-    pkgId = packageId $ localPkgDescr lbi--currentCabalId :: PackageIdentifier-currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion--currentCompilerId :: PackageIdentifier-currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)-                                      System.Info.compilerVersion--parseHeader :: ByteString -> (PackageIdentifier, PackageIdentifier)-parseHeader header = case BLC8.words header of-  ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, "using", compId] ->-      fromMaybe (throw ConfigStateFileBadHeader) $ do-          _ <- simpleParse (BLC8.unpack pkgId) :: Maybe PackageIdentifier-          cabalId' <- simpleParse (BLC8.unpack cabalId)-          compId' <- simpleParse (BLC8.unpack compId)-          return (cabalId', compId')-  _ -> throw ConfigStateFileNoHeader--showHeader :: PackageIdentifier -> ByteString-showHeader pkgId = BLC8.unwords-    [ "Saved", "package", "config", "for"-    , BLC8.pack $ display pkgId-    , "written", "by"-    , BLC8.pack $ display currentCabalId-    , "using"-    , BLC8.pack $ display currentCompilerId-    ]---- |Check that localBuildInfoFile is up-to-date with respect to the--- .cabal file.-checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool-checkPersistBuildConfigOutdated distPref pkg_descr_file = do-  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)---- |@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)--        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.")--        createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref--        let programsConfig = mkProgramsConfig cfg (configPrograms cfg)-            userInstall    = fromFlag (configUserInstall cfg)-            packageDbs     = interpretPackageDbFlags userInstall-                             (configPackageDBs cfg)--        -- detect compiler-        (comp, compPlatform, programsConfig') <- configCompilerEx-          (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'--        (allConstraints, requiredDepsMap) <- either die return $-          combinedConstraints (configConstraints cfg)-                              (configDependencies cfg)-                              installedPackageSet--        let exactConf = fromFlagOrDefault False (configExactConfiguration cfg)-            -- Constraint test function for the solver-            dependencySatisfiable d@(Dependency depName verRange)-              | exactConf =-                -- 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,-                -- 'finalizePackageDescription' will fail.-                ---                -- TODO: mention '--exact-configuration' in the error message-                -- when this fails?-                (depName `Map.member` requiredDepsMap) || isInternalDep--              | otherwise =-                -- Normal operation: just look up dependency in the package-                -- index.-                not . null . PackageIndex.lookupDependency pkgs' $ d-              where-                pkgs' = PackageIndex.insert internalPackage installedPackageSet-                isInternalDep = pkgName pid == depName-                                && pkgVersion pid `withinRange` verRange-            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-                       compPlatform-                       (compilerInfo comp)-                       allConstraints-                       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)--        -- Sanity check: if '--exact-configuration' was given, ensure that the-        -- complete flag assignment was specified on the command line.-        when exactConf $ do-          let cmdlineFlags = map fst (configConfigurationsFlags cfg)-              allFlags     = map flagName . genPackageFlags $ pkg_descr0-              diffFlags    = allFlags \\ cmdlineFlags-          when (not . null $ diffFlags) $-            die $ "'--exact-conf' was given, "-            ++ "but the following flags were not specified: "-            ++ intercalate ", " (map show diffFlags)--        -- add extra include/lib dirs as specified in cfg-        -- we do it here so that those get checked too-        let pkg_descr = addExtraIncludeLibDirs pkg_descr0'--        unless (renamingPackageFlagsSupported comp ||-                    and [ rn == defaultRenaming-                        | bi <- allBuildInfo pkg_descr-                        , rn <- Map.elems (targetBuildRenaming bi)]) $-            die $ "Your compiler does not support thinning and renaming on "-               ++ "package flags.  To use this feature you probably must use "-               ++ "GHC 7.9 or later."--        when (not (null flags)) $-          info verbosity $ "Flags chosen: "-                        ++ intercalate ", " [ name ++ "=" ++ display value-                                            | (FlagName name, value) <- flags ]--        when (maybe False (not.null.PD.reexportedModules) (PD.library pkg_descr)-              && not (reexportedModulesSupported comp)) $ do-            die $ "Your compiler does not support module re-exports. To use "-               ++ "this feature you probably must use GHC 7.9 or later."--        checkPackageProblems verbosity pkg_descr0-          (updatePackageDescription pbi pkg_descr)--        -- Handle hole instantiation-        (holeDeps, hole_insts) <- configureInstantiateWith pkg_descr cfg installedPackageSet--        let selectDependencies :: [Dependency] ->-                                  ([FailedDependency], [ResolvedDependency])-            selectDependencies =-                (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))-              . map (selectDependency internalPackageSet installedPackageSet-                                      requiredDepsMap)--            (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--        let installDeps = Map.elems-                        . Map.fromList-                        . map (\v -> (Installed.installedPackageId v, v))-                        $ externalPkgDeps ++ holeDeps--        packageDependsIndex <--          case PackageIndex.dependencyClosure installedPackageSet-                  (map Installed.installedPackageId installDeps) 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 installDeps-              }-        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 ]--        -- Calculate the package key.  We're going to store it in LocalBuildInfo-        -- canonically, but ComponentsLocalBuildInfo also needs to know about it-        -- XXX Do we need the internal deps?-        -- NB: does *not* include holeDeps!-        let pkg_key = mkPackageKey (packageKeySupported comp)-                                   (package pkg_descr)-                                   (map Installed.packageKey externalPkgDeps)-                                   (map (\(k,(p,m)) -> (k,(Installed.packageKey p,m))) hole_insts)--        -- internal component graph-        buildComponents <--          case mkComponentsGraph pkg_descr internalPkgDeps of-            Left  componentCycle -> reportComponentCycle componentCycle-            Right components     ->-              case mkComponentsLocalBuildInfo packageDependsIndex pkg_descr-                                              internalPkgDeps externalPkgDeps holeDeps-                                              (Map.fromList hole_insts)-                                              pkg_key components of-                Left  problems    -> reportModuleReexportProblems problems-                Right components' -> return components'--        -- 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-                            GHCJS                             -> return True-                            _ -> do warn verbosity-                                         ("this compiler does not support " ++-                                          "--enable-split-objs; ignoring")-                                    return False--        let ghciLibByDefault =-              case compilerId comp of-                CompilerId GHC _ ->-                  -- If ghc is non-dynamic, then ghci needs object files,-                  -- so we build one by default.-                  ---                  -- Technically, archive files should be sufficient for ghci,-                  -- but because of GHC bug #8942, it has never been safe to-                  -- rely on them. By the time that bug was fixed, ghci had-                  -- been changed to read shared libraries instead of archive-                  -- files (see next code block).-                  not (GHC.isDynamic comp)-                CompilerId GHCJS _ ->-                  not (GHCJS.isDynamic comp)-                _ -> False--        let sharedLibsByDefault-              | fromFlag (configDynExe cfg) =-                  -- build a shared library if dynamically-linked-                  -- executables are requested-                  True-              | otherwise = case compilerId comp of-                CompilerId GHC _ ->-                  -- if ghc is dynamic, then ghci needs a shared-                  -- library, so we build one by default.-                  GHC.isDynamic comp-                CompilerId GHCJS _ ->-                  GHCJS.isDynamic comp-                _ -> False-            withSharedLib_ =-                -- build shared libraries if required by GHC or by the-                -- executable linking mode, but allow the user to force-                -- building only static library archives with-                -- --disable-shared.-                fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg-            withDynExe_ = fromFlag $ configDynExe cfg-        when (withDynExe_ && not withSharedLib_) $ warn verbosity $-               "Executables will use dynamic linking, but a shared library "-            ++ "is not being built. Linking will fail if any executables "-            ++ "depend on the library."--        let withProfExe_ = fromFlagOrDefault False $ configProfExe cfg-            withProfLib_ = fromFlagOrDefault withProfExe_ $ configProfLib cfg-        when (withProfExe_ && not withProfLib_) $ warn verbosity $-               "Executables will be built with profiling, but library "-            ++ "profiling is disabled. Linking will fail if any executables "-            ++ "depend on the library."--        let configCoverage_ =-              mappend (configCoverage cfg) (configLibCoverage cfg)--            cfg' = cfg { configCoverage = configCoverage_ }--        reloc <--           if not (fromFlag $ configRelocatable cfg)-                then return False-                else return True--        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,-                    hostPlatform        = compPlatform,-                    buildDir            = buildDir',-                    componentsConfigs   = buildComponents,-                    installedPkgs       = packageDependsIndex,-                    pkgDescrFile        = Nothing,-                    localPkgDescr       = pkg_descr',-                    pkgKey              = pkg_key,-                    instantiatedWith    = hole_insts,-                    withPrograms        = programsConfig''',-                    withVanillaLib      = fromFlag $ configVanillaLib cfg,-                    withProfLib         = withProfLib_,-                    withSharedLib       = withSharedLib_,-                    withDynExe          = withDynExe_,-                    withProfExe         = withProfExe_,-                    withOptimization    = fromFlag $ configOptimization cfg,-                    withDebugInfo       = fromFlag $ configDebugInfo cfg,-                    withGHCiLib         = fromFlagOrDefault ghciLibByDefault $-                                          configGHCiLib cfg,-                    splitObjs           = split_objs,-                    stripExes           = fromFlag $ configStripExes cfg,-                    stripLibs           = fromFlag $ configStripLibs cfg,-                    withPackageDB       = packageDbs,-                    progPrefix          = fromFlag $ configProgPrefix cfg,-                    progSuffix          = fromFlag $ configProgSuffix cfg,-                    relocatable         = reloc-                  }--        when reloc (checkRelocatable verbosity pkg_descr lbi)--        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)-        dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir 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}--mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration-mkProgramsConfig cfg initialProgramsConfig = programsConfig-  where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   . setProgramSearchPath searchpath-                   $ initialProgramsConfig-    searchpath     = getProgramSearchPath (initialProgramsConfig)-                  ++ map ProgramSearchPathDir (fromNubList $ configProgramPathExtra cfg)---- -------------------------------------------------------------------------------- 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 :: InstalledPackageIndex  -- ^ Internally defined packages-                 -> InstalledPackageIndex  -- ^ Installed packages-                 -> Map PackageName InstalledPackageInfo-                    -- ^ Packages for which we have been given specific deps to use-                 -> Dependency-                 -> Either FailedDependency ResolvedDependency-selectDependency internalIndex installedIndex requiredDepsMap-  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 Map.lookup pkgname requiredDepsMap of-      -- If we know the exact pkg to use, then use it.-      Just pkginstance -> Right (ExternalDependency dep pkginstance)-      -- Otherwise we just pick an arbitrary instance of the latest version.-      Nothing -> case PackageIndex.lookupDependency installedIndex dep of-        []   -> Left  $ DependencyNotExists pkgname-        pkgs -> Right $ ExternalDependency dep $-                case last pkgs of-                  (_ver, pkginstances) -> head pkginstances--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 InstalledPackageIndex-getInstalledPackages verbosity comp packageDBs progconf = do-  when (null packageDBs) $-    die $ "No package databases have been specified. If you use "-       ++ "--package-db=clear, you must follow it with --package-db= "-       ++ "with 'global', 'user' or a specific file."--  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC   -> GHC.getInstalledPackages verbosity packageDBs progconf-    GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs progconf-    JHC   -> JHC.getInstalledPackages verbosity packageDBs progconf-    LHC   -> LHC.getInstalledPackages verbosity packageDBs progconf-    UHC   -> UHC.getInstalledPackages verbosity comp packageDBs progconf-    HaskellSuite {} ->-      HaskellSuite.getInstalledPackages verbosity packageDBs progconf-    flv -> die $ "don't know how to find the installed packages for "-              ++ display flv---- | Like 'getInstalledPackages', but for a single package DB.-getPackageDBContents :: Verbosity -> Compiler-                     -> PackageDB -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity comp packageDB progconf = do-  info verbosity "Reading installed packages..."-  case compilerFlavor comp of-    GHC -> GHC.getPackageDBContents verbosity packageDB progconf-    GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progconf-    -- For other compilers, try to fall back on 'getInstalledPackages'.-    _   -> getInstalledPackages verbosity comp [packageDB] progconf----- | The user interface specifies the package dbs to use with a combination of--- @--global@, @--user@ and @--package-db=global|user|clear|$file@.--- This function combines the global/user flag and interprets the package-db--- flag into a single package db stack.----interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack-interpretPackageDbFlags userInstall specificDBs =-    extra initialStack specificDBs-  where-    initialStack | userInstall = [GlobalPackageDB, UserPackageDB]-                 | otherwise   = [GlobalPackageDB]--    extra dbs' []            = dbs'-    extra _    (Nothing:dbs) = extra []             dbs-    extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs--newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version [1,7,1] []---- 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---- 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 :: [Dependency] ->-                       [(PackageName, InstalledPackageId)] ->-                       InstalledPackageIndex ->-                       Either String ([Dependency],-                                      Map PackageName InstalledPackageInfo)-combinedConstraints constraints dependencies installedPackages = do--    when (not (null badInstalledPackageIds)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badInstalledPackageIds)-         $+$ text "however the given installed package instance does not exist."--    when (not (null badNames)) $-      Left $ render $ text "The following package dependencies were requested"-         $+$ nest 4 (dispDependencies badNames)-         $+$ text "however the installed package's name does not match the name given."--    --TODO: we don't check that all dependencies are used!--    return (allConstraints, idConstraintMap)--  where-    allConstraints :: [Dependency]-    allConstraints = constraints-                  ++ [ thisPackageVersion (packageId pkg)-                     | (_, _, Just pkg) <- dependenciesPkgInfo ]--    idConstraintMap :: Map PackageName InstalledPackageInfo-    idConstraintMap = Map.fromList-                        [ (packageName pkg, pkg)-                        | (_, _, Just pkg) <- dependenciesPkgInfo ]--    -- The dependencies along with the installed package info, if it exists-    dependenciesPkgInfo :: [(PackageName, InstalledPackageId,-                             Maybe InstalledPackageInfo)]-    dependenciesPkgInfo =-      [ (pkgname, ipkgid, mpkg)-      | (pkgname, ipkgid) <- dependencies-      , let mpkg = PackageIndex.lookupInstalledPackageId-                     installedPackages ipkgid-      ]--    -- 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.-    badInstalledPackageIds =-      [ (pkgname, ipkgid)-      | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]--    -- If someone has written e.g.-    -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have-    -- probably made a mistake.-    badNames =-      [ (requestedPkgName, ipkgid)-      | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo-      , let foundPkgName = packageName pkg-      , requestedPkgName /= foundPkgName ]--    dispDependencies deps =-      hsep [    text "--dependency="-             <> quotes (disp pkgname <> char '=' <> disp ipkgid)-           | (pkgname, ipkgid) <- deps ]---- -------------------------------------------------------------------------------- Configuring hole instantiation--configureInstantiateWith :: PackageDescription-                         -> ConfigFlags-                         -> InstalledPackageIndex -- ^ installed packages-                         -> IO ([InstalledPackageInfo],-                                [(ModuleName, (InstalledPackageInfo, ModuleName))])-configureInstantiateWith pkg_descr cfg installedPackageSet = do-        -- Holes: First, check and make sure the provided instantiation covers-        -- all the holes we know about.  Indefinite package installation is-        -- not handled at all at this point.-        -- NB: We union together /all/ of the requirements when calculating-        -- the package key.-        -- NB: For now, we assume that dependencies don't contribute signatures.-        -- This will be handled by cabal-install; as far as ./Setup is-        -- concerned, the most important thing is to be provided correctly-        -- built dependencies.-        let signatures =-              maybe [] (\lib -> requiredSignatures lib ++ exposedSignatures lib)-                (PD.library pkg_descr)-            signatureSet = Set.fromList signatures-            instantiateMap = Map.fromList (configInstantiateWith cfg)-            missing_impls = filter (not . flip Map.member instantiateMap) signatures-            hole_insts0 = filter (\(k,_) -> Set.member k signatureSet) (configInstantiateWith cfg)--        when (not (null missing_impls)) $-          die $ "Missing signature implementations for these modules: "-            ++ intercalate ", " (map display missing_impls)--        -- Holes: Next, we need to make sure we have packages to actually-        -- provide the implementations we're talking about.  This is on top-        -- of the normal dependency resolution process.-        -- TODO: internal dependencies (e.g. the test package depending on the-        -- main library) is not currently supported-        let selectHoleDependency (k,(i,m)) =-              case PackageIndex.lookupInstalledPackageId installedPackageSet i of-                Just pkginst -> Right (k,(pkginst, m))-                Nothing -> Left i-            (failed_hmap, hole_insts) = partitionEithers (map selectHoleDependency hole_insts0)-            holeDeps = map (fst.snd) hole_insts -- could have dups--        -- Holes: Finally, any dependencies selected this way have to be-        -- included in the allPkgs index, as well as the buildComponents.-        -- But don't report these as potential inconsistencies!--        when (not (null failed_hmap)) $-          die $ "Could not resolve these package IDs (from signature implementations): "-            ++ intercalate ", " (map display failed_hmap)--        return (holeDeps, hole_insts)---- -------------------------------------------------------------------------------- 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' <- mapM addPkgConfigBILib (library pkg_descr)-    exes' <- mapM addPkgConfigBIExe (executables pkg_descr)-    tests' <- mapM addPkgConfigBITest (testSuites pkg_descr)-    benches' <- mapM addPkgConfigBIBench (benchmarks pkg_descr)-    let pkg_descr' = pkg_descr { library = lib', executables = exes',-                                 testSuites = tests', benchmarks = benches' }-    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--    -- 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 :: [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--configCompilerAuxEx :: ConfigFlags-                    -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)-                                           (flagToMaybe $ configHcPath cfg)-                                           (flagToMaybe $ configHcPkg cfg)-                                           programsConfig-                                           (fromFlag (configVerbosity cfg))-  where-    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration--configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-                 -> ProgramConfiguration -> Verbosity-                 -> IO (Compiler, Platform, ProgramConfiguration)-configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"-configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do-  (comp, maybePlatform, programsConfig) <- case hcFlavor of-    GHC   -> GHC.configure  verbosity hcPath hcPkg conf-    GHCJS -> GHCJS.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-    UHC   -> UHC.configure  verbosity hcPath hcPkg conf-    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf-    _    -> die "Unknown compiler"-  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)---- Ideally we would like to not have separate configCompiler* and--- configCompiler*Ex sets of functions, but there are many custom setup scripts--- in the wild that are using them, so the versions with old types are kept for--- backwards compatibility. Platform was added to the return triple in 1.18.--{-# DEPRECATED configCompiler-    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-}-configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath-               -> ProgramConfiguration -> Verbosity-               -> IO (Compiler, ProgramConfiguration)-configCompiler mFlavor hcPath hcPkg conf verbosity =-  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity--{-# DEPRECATED configCompilerAux-    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}-configCompilerAux :: ConfigFlags-                  -> IO (Compiler, ProgramConfiguration)-configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx---- -------------------------------------------------------------------------------- Making the internal component graph---mkComponentsGraph :: PackageDescription-                  -> [PackageId]-                  -> Either [ComponentName]-                            [(Component, [ComponentName])]-mkComponentsGraph pkg_descr internalPkgDeps =-    let graph = [ (c, componentName c, componentDeps c)-                | c <- pkgEnabledComponents pkg_descr ]-     in case checkComponentsCyclic graph of-          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]-          Nothing     -> Right [ (c, cdeps) | (c, _, cdeps) <- graph ]-  where-    -- The dependencies for the given component-    componentDeps component =-         [ CExeName toolname | Dependency (PackageName toolname) _-                               <- buildTools bi-                             , toolname `elem` map exeName-                               (executables pkg_descr) ]--      ++ [ CLibName          | Dependency pkgname _ <- targetBuildDepends bi-                             , pkgname `elem` map packageName internalPkgDeps ]-      where-        bi = componentBuildInfo component--reportComponentCycle :: [ComponentName] -> IO a-reportComponentCycle cnames =-    die $ "Components in the package depend on each other in a cyclic way:\n  "-       ++ intercalate " depends on "-            [ "'" ++ showComponentName cname ++ "'"-            | cname <- cnames ++ [head cnames] ]--mkComponentsLocalBuildInfo :: InstalledPackageIndex-                           -> PackageDescription-                           -> [PackageId] -- internal package deps-                           -> [InstalledPackageInfo] -- external package deps-                           -> [InstalledPackageInfo] -- hole package deps-                           -> Map ModuleName (InstalledPackageInfo, ModuleName)-                           -> PackageKey-                           -> [(Component, [ComponentName])]-                           -> Either [(ModuleReexport, String)] -- errors-                                     [(ComponentName, ComponentLocalBuildInfo,-                                                      [ComponentName])] -- ok-mkComponentsLocalBuildInfo installedPackages pkg_descr-                           internalPkgDeps externalPkgDeps holePkgDeps hole_insts-                           pkg_key graph =-    sequence-      [ do clbi <- componentLocalBuildInfo c-           return (componentName c, clbi, cdeps)-      | (c, cdeps) <- graph ]-  where-    -- 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.-    componentLocalBuildInfo component =-      case component of-      CLib lib -> do-        let exports = map (\n -> Installed.ExposedModule n Nothing Nothing)-                          (PD.exposedModules lib)-            esigs = map (\n -> Installed.ExposedModule n Nothing-                                (fmap (\(pkg,m) -> Installed.OriginalModule-                                                      (Installed.installedPackageId pkg) m)-                                      (Map.lookup n hole_insts)))-                        (PD.exposedSignatures lib)-        reexports <- resolveModuleReexports installedPackages-                                            (packageId pkg_descr)-                                            externalPkgDeps lib-        return LibComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentLibraries   = [ LibraryName ("HS" ++ packageKeyLibraryName (package pkg_descr) pkg_key) ],-          componentPackageRenaming = cprns,-          componentExposedModules = exports ++ reexports ++ esigs-        }-      CExe _ ->-        return ExeComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      CTest _ ->-        return TestComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      CBench _ ->-        return BenchComponentLocalBuildInfo {-          componentPackageDeps = cpds,-          componentPackageRenaming = cprns-        }-      where-        bi = componentBuildInfo component-        dedup = Map.toList . Map.fromList-        cpds = if newPackageDepsBehaviour pkg_descr-               then dedup $-                    [ (Installed.installedPackageId pkg, packageId pkg)-                    | pkg <- selectSubset bi externalPkgDeps ]-                 ++ [ (inplacePackageId pkgid, pkgid)-                    | pkgid <- selectSubset bi internalPkgDeps ]-                 ++ [ (Installed.installedPackageId pkg, packageId pkg)-                    | pkg <- holePkgDeps ]-               else [ (Installed.installedPackageId pkg, packageId pkg)-                    | pkg <- externalPkgDeps ]-        cprns = if newPackageDepsBehaviour pkg_descr-                then Map.unionWith mappend-                        -- We need hole dependencies passed to GHC, so add them here-                        -- (but note that they're fully thinned out.  If they-                        -- appeared legitimately the monoid instance will-                        -- fill them out.-                        (Map.fromList [(packageName pkg, mempty) | pkg <- holePkgDeps])-                        (targetBuildRenaming bi)-                -- Hack: if we have old package-deps behavior, it's impossible-                -- for non-default renamings to be used, because the Cabal-                -- version is too early.  This is a good, because while all the-                -- deps were bundled up in buildDepends, we didn't do this for-                -- renamings, so it's not even clear how to get the merged-                -- version.  So just assume that all of them are the default..-                else Map.fromList (map (\(_,pid) -> (packageName pid, defaultRenaming)) cpds)--    selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]-    selectSubset bi pkgs =-        [ pkg | pkg <- pkgs, packageName pkg `elem` names bi ]--    names bi = [ name | Dependency name _ <- targetBuildDepends bi ]---- | Given the author-specified re-export declarations from the .cabal file,--- resolve them to the form that we need for the package database.------ An invariant of the package database is that we always link the re-export--- directly to its original defining location (rather than indirectly via a--- chain of re-exporting packages).----resolveModuleReexports :: InstalledPackageIndex-                       -> PackageId-                       -> [InstalledPackageInfo]-                       -> Library-                       -> Either [(ModuleReexport, String)] -- errors-                                 [Installed.ExposedModule] -- ok-resolveModuleReexports installedPackages srcpkgid externalPkgDeps lib =-    case partitionEithers (map resolveModuleReexport (PD.reexportedModules lib)) of-      ([],  ok) -> Right ok-      (errs, _) -> Left  errs-  where-    -- A mapping from visible module names to their original defining-    -- module name.  We also record the package name of the package which-    -- *immediately* provided the module (not the original) to handle if the-    -- user explicitly says which build-depends they want to reexport from.-    visibleModules :: Map ModuleName [(PackageName, Installed.ExposedModule)]-    visibleModules =-      Map.fromListWith (++) $-        [ (Installed.exposedName exposedModule, [(exportingPackageName,-                                                  exposedModule)])-          -- The package index here contains all the indirect deps of the-          -- package we're configuring, but we want just the direct deps-        | let directDeps = Set.fromList (map Installed.installedPackageId externalPkgDeps)-        , pkg <- PackageIndex.allPackages installedPackages-        , Installed.installedPackageId pkg `Set.member` directDeps-        , let exportingPackageName = packageName pkg-        , exposedModule <- visibleModuleDetails pkg-        ]-     ++ [ (visibleModuleName, [(exportingPackageName, exposedModule)])-        | visibleModuleName <- PD.exposedModules lib-                            ++ otherModules (libBuildInfo lib)-        , let exportingPackageName = packageName srcpkgid-              definingModuleName   = visibleModuleName-              -- we don't know the InstalledPackageId of this package yet-              -- we will fill it in later, before registration.-              definingPackageId    = InstalledPackageId ""-              originalModule = Installed.OriginalModule definingPackageId-                                                        definingModuleName-              exposedModule  = Installed.ExposedModule visibleModuleName-                                                       (Just originalModule)-                                                             Nothing-        ]--    -- All the modules exported from this package and their defining name and-    -- package (either defined here in this package or re-exported from some-    -- other package).  Return an ExposedModule because we want to hold onto-    -- signature information.-    visibleModuleDetails :: InstalledPackageInfo -> [Installed.ExposedModule]-    visibleModuleDetails pkg = do-        exposedModule <- Installed.exposedModules pkg-        case Installed.exposedReexport exposedModule of-        -- The first case is the modules actually defined in this package.-        -- In this case the reexport will point to this package.-            Nothing -> return exposedModule { Installed.exposedReexport =-                            Just (Installed.OriginalModule (Installed.installedPackageId pkg)-                                                 (Installed.exposedName exposedModule)) }-        -- On the other hand, a visible module might actually be itself-        -- a re-export! In this case, the re-export info for the package-        -- doing the re-export will point us to the original defining-        -- module name and package, so we can reuse the entry.-            Just _ -> return exposedModule--    resolveModuleReexport reexport@ModuleReexport {-         moduleReexportOriginalPackage = moriginalPackageName,-         moduleReexportOriginalName    = originalName,-         moduleReexportName            = newName-      } =--      let filterForSpecificPackage =-            case moriginalPackageName of-              Nothing                  -> id-              Just originalPackageName ->-                filter (\(pkgname, _) -> pkgname == originalPackageName)--          matches = filterForSpecificPackage-                      (Map.findWithDefault [] originalName visibleModules)-      in-      case (matches, moriginalPackageName) of-        ((_, exposedModule):rest, _)-          -- TODO: Refine this check for signatures-          | all (\(_, exposedModule') -> Installed.exposedReexport exposedModule-                                      == Installed.exposedReexport exposedModule') rest-           -> Right exposedModule { Installed.exposedName = newName }--        ([], Just originalPackageName)-           -> Left $ (,) reexport-                   $ "The package " ++ display originalPackageName-                  ++ " does not export a module " ++ display originalName--        ([], Nothing)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName-                  ++ " is not exported by any suitable package (this package "-                  ++ "itself nor any of its 'build-depends' dependencies)."--        (ms, _)-           -> Left $ (,) reexport-                   $ "The module " ++ display originalName ++ " is exported "-                  ++ "by more than one package ("-                  ++ intercalate ", " [ display pkgname | (pkgname,_) <- ms ]-                  ++ ") and so the re-export is ambiguous. The ambiguity can "-                  ++ "be resolved by qualifying by the package name. The "-                  ++ "syntax is 'packagename:moduleName [as newname]'."--        -- Note: if in future Cabal allows directly depending on multiple-        -- instances of the same package (e.g. backpack) then an additional-        -- ambiguity case is possible here: (_, Just originalPackageName)-        -- with the module being ambigious despite being qualified by a-        -- package name. Presumably by that time we'll have a mechanism to-        -- qualify the instance we're referring to.--reportModuleReexportProblems :: [(ModuleReexport, String)] -> IO a-reportModuleReexportProblems reexportProblems =-  die $ unlines-    [ "Problem with the module re-export '" ++ display reexport ++ "': " ++ msg-    | (reexport, msg) <- reexportProblems ]---- -------------------------------------------------------------------------------- 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 = 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 = platformDefines 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 _ _-           | isNothing . lookupProgram gccProgram . withPrograms $ lbi--                              = die $ unlines $-              [ "No working gcc",-                  "This package depends on foreign library but we cannot "-               ++ "find a working C compiler. If you have it in a "-               ++ "non-standard location you can use the --with-gcc "-               ++ "flag to specify it." ]--        explainErrors hdr libs = die $ 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."---- | 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 die (intercalate "\n\n" errors)---- | Preform checks if a relocatable build is allowed-checkRelocatable :: Verbosity-                 -> PackageDescription-                 -> LocalBuildInfo-                 -> IO ()-checkRelocatable verbosity pkg lbi-    = sequence_ [ checkOS-                , checkCompiler-                , packagePrefixRelative-                , depsPrefixRelative-                ]-  where-    -- Check if the OS support relocatable builds.-    ---    -- If you add new OS' to this list, and your OS supports dynamic libraries-    -- and RPATH, make sure you add your OS to RPATH-support list of:-    -- Distribution.Simple.GHC.getRPaths-    checkOS-        = unless (os `elem` [ OSX, Linux ])-        $ die $ "Operating system: " ++ display os ++-                ", does not support relocatable builds"-      where-        (Platform _ os) = hostPlatform lbi--    -- Check if the Compiler support relocatable builds-    checkCompiler-        = unless (compilerFlavor comp `elem` [ GHC ])-        $ die $ "Compiler: " ++ show comp ++-                ", does not support relocatable builds"-      where-        comp = compiler lbi--    -- Check if all the install dirs are relative to same prefix-    packagePrefixRelative-        = unless (relativeInstallDirs installDirs)-        $ die $ "Installation directories are not prefix_relative:\n" ++-                show installDirs-      where-        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 (last (withPackageDB lbi))-        mapM_ (doCheck pkgr) ipkgs-      where-        doCheck pkgr ipkg-          | maybe False (== pkgr) (Installed.pkgRoot ipkg)-          = mapM_ (\l -> when (isNothing $ stripPrefix p l) (die (msg l)))-                  (Installed.libraryDirs ipkg)-          | otherwise-          = return ()-        installDirs   = absoluteInstallDirs pkg lbi NoCopyDest-        p             = prefix installDirs-        ipkgs         = PackageIndex.allPackages (installedPkgs lbi)-        msg l         = "Library directory of a dependency: " ++ show l ++-                        "\nis not relative to the installation prefix:\n" ++-                        show p
− Distribution/Simple/GHC.hs 
@@ -1,1113 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC--- Copyright   :  Isaac Jones 2003-2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is a fairly large module. It contains most of the GHC-specific code for--- configuring, building and installing packages. It also exports a function--- for finding out what packages are already installed. Configuring involves--- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions--- this version of ghc supports and returning a 'Compiler' value.------ 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out--- what packages are installed.------ Building is somewhat complex as there is quite a bit of information to take--- into account. We have to build libs and programs, possibly for profiling and--- shared libs. We have to support building libraries that will be usable by--- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files--- using ghc. Linking, especially for @split-objs@ is remarkably complex,--- partly because there tend to be 1,000's of @.o@ files and this can often be--- more than we can pass to the @ld@ or @ar@ programs in one go.------ Installing for libs and exes involves finding the right files and copying--- them to the right places. One of the more tricky things about this module is--- remembering the layout of files in the build directory (which is not--- explicitly documented) and thus what search dirs are used for various kinds--- of files.--module Distribution.Simple.GHC (-        getGhcInfo,-        configure, getInstalledPackages, getPackageDBContents,-        buildLib, buildExe,-        replLib, replExe,-        startInterpreter,-        installLib, installExe,-        libAbiHash,-        hcPkgInfo,-        registerPackage,-        componentGhcOptions,-        getLibDir,-        isDynamic,-        getGlobalPackageDB,-        pkgRoot- ) where--import qualified Distribution.Simple.GHC.IPI641 as IPI641-import qualified Distribution.Simple.GHC.IPI642 as IPI642-import qualified Distribution.Simple.GHC.Internal as Internal-import Distribution.Simple.GHC.ImplInfo-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)-         , allExtensions, libModules, exeModules-         , hcOptions, hcSharedOptions, hcProfOptions )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.Simple.PackageIndex (InstalledPackageIndex)-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , absoluteInstallDirs, depLibraryPaths )-import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-         ( PackageName(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput, requireProgramVersion, requireProgram-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , ghcProgram, ghcPkgProgram, hsc2hsProgram, ldProgram )-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import qualified Distribution.Simple.Program.Ar    as Ar-import qualified Distribution.Simple.Program.Ld    as Ld-import qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-         ( toFlag, fromFlag, fromFlagOrDefault, configCoverage, configDistPref )-import qualified Distribution.Simple.Setup as Cabal-        ( Flag(..) )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , PackageDB(..), PackageDBStack, AbiTag(..) )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.System-         ( Platform(..), OS(..) )-import Distribution.Verbosity-import Distribution.Text-         ( display )-import Distribution.Utils.NubList-         ( NubListR, overNubListR, toNubListR )-import Language.Haskell.Extension (Extension(..), KnownExtension(..))--import Control.Monad            ( unless, when )-import Data.Char                ( isDigit, isSpace )-import Data.List-import qualified Data.Map as M  ( fromList )-import Data.Maybe               ( catMaybes )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif-import Data.Version             ( showVersion )-import System.Directory-         ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension,-                                  splitExtension, isRelative )-import qualified System.Info---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration-          -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf0 = do--  (ghcProg, ghcVersion, conf1) <--    requireProgramVersion verbosity ghcProgram-      (orLaterVersion (Version [6,4] []))-      (userMaybeSpecifyPath "ghc" hcPath conf0)-  let implInfo = ghcVersionImplInfo ghcVersion--  -- This is slightly tricky, we have to configure ghc first, then we use the-  -- location of ghc to help find ghc-pkg in the case that the user did not-  -- specify the location of ghc-pkg directly:-  (ghcPkgProg, ghcPkgVersion, 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  <- Internal.getLanguages verbosity implInfo ghcProg-  extensions <- Internal.getExtensions verbosity implInfo ghcProg--  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg-  let ghcInfoMap = M.fromList ghcInfo--  let comp = Compiler {-        compilerId         = CompilerId GHC ghcVersion,-        compilerAbiTag     = NoAbiTag,-        compilerCompat     = [],-        compilerLanguages  = languages,-        compilerExtensions = extensions,-        compilerProperties = ghcInfoMap-      }-      compPlatform = Internal.targetPlatform ghcInfo-      conf4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap conf3 -- configure gcc and ld-  return (comp, compPlatform, 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 :: Program -> ConfiguredProgram-                     -> Verbosity -> ProgramSearchPath-                     -> IO (Maybe FilePath)-guessToolFromGhcPath tool ghcProg verbosity searchpath-  = do let toolname          = programName tool-           path              = programPath ghcProg-           dir               = takeDirectory path-           versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> toolname <.> exeExtension-           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)-                               <.> exeExtension-           guessVersioned    = dir </> (toolname ++ versionSuffix)-                               <.> exeExtension-           guesses | null versionSuffix = [guessNormal]-                   | otherwise          = [guessGhcVersioned,-                                           guessVersioned,-                                           guessNormal]-       info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ dir-       exists <- mapM 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-                      return (Just fp)--  where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = takeWhileEndLE isSuffixChar--        isSuffixChar :: Char -> Bool-        isSuffixChar c = isDigit c || c == '.' || c == '-'--        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 -> ProgramSearchPath -> IO (Maybe 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)-guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram--getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]-getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg-  where-    Just version = programVersion ghcProg-    implInfo = ghcVersionImplInfo version---- | Given a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration-                        -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb conf = do-  pkgss <- getInstalledPackages' verbosity [packagedb] conf-  toPackageIndex verbosity pkgss conf---- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbEnvVar-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  index <- toPackageIndex verbosity pkgss conf-  return $! hackRtsPackage index--  where-    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 test suite does some crazy stuff.---- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a--- @PackageIndex@. Helper function used by 'getPackageDBContents' and--- 'getInstalledPackages'.-toPackageIndex :: Verbosity-               -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramConfiguration-               -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss conf = 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-    Just ghcProg = lookupProgram ghcProgram conf--getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-getLibDir verbosity lbi =-    dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram-     (withPrograms lbi) ["--print-libdir"]--getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-getLibDir' verbosity ghcProg =-    dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]----- | Return the 'FilePath' to the global GHC package database.-getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath-getGlobalPackageDB verbosity ghcProg =-    dropWhileEndLE isSpace `fmap`-     rawSystemProgramStdout verbosity ghcProg ["--print-global-package-db"]--checkPackageDbEnvVar :: IO ()-checkPackageDbEnvVar =-    Internal.checkPackageDbEnvVar "GHC" "GHC_PACKAGE_PATH"--checkPackageDbStack :: PackageDBStack -> IO ()-checkPackageDbStack (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack rest-  | GlobalPackageDB `notElem` rest =-  die $ "With current ghc versions the global package db is always used "-     ++ "and must be listed first. This ghc limitation may be lifted in "-     ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"-checkPackageDbStack _ =-  die $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"---- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This--- breaks when you want to use a different gcc, so we need to filter--- it out.-removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo-removeMingwIncludeDir pkg =-    let ids = InstalledPackageInfo.includeDirs pkg-        ids' = filter (not . ("mingw" `isSuffixOf`)) ids-    in pkg { InstalledPackageInfo.includeDirs = ids' }---- | Get the packages from specific PackageDBs, not cumulative.----getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration-                     -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf-  | ghcVersion >= Version [6,9] [] =-  sequence-    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]--  where-    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---- -------------------------------------------------------------------------------- Building---- | Build a library with GHC.----buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib = buildOrReplLib False-replLib  = buildOrReplLib True--buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Library            -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"--  let libTargetDir = buildDir lbi-      whenVanillaLib forceVanilla =-        when (forceVanilla || withVanillaLib lbi)-      whenProfLib = when (withProfLib lbi)-      whenSharedLib forceShared =-        when (forceShared || withSharedLib lbi)-      whenGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)-      ifReplLib = when forRepl-      comp = compiler lbi-      ghcVersion = compilerVersion comp-      implInfo  = getImplInfo comp-      (Platform _hostArch hostOS) = hostPlatform lbi-      hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) (instantiatedWith lbi)--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg comp--  libBi <- hackThreadedFlag verbosity-             comp (withProfLib lbi) (libBuildInfo lib)--  let isGhcDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi-      forceVanillaLib = doingTH && not isGhcDynamic-      forceSharedLib  = doingTH &&     isGhcDynamic-      -- TH always needs default libs, even when building for profiling--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi-      -- Component name. Not 'libName' because that has the "HS" prefix-      -- that GHC gives Haskell libraries.-      cname = display $ PD.package $ localPkgDescr lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname-        | otherwise = mempty--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)-      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir-      vanillaOpts = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = numJobs,-                      ghcOptPackageKey   = toFlag (pkgKey lbi),-                      ghcOptSigOf        = hole_insts,-                      ghcOptInputModules = toNubListR $ libModules lib,-                      ghcOptHPCDir       = hpcdir Hpc.Vanilla-                    }--      profOpts    = vanillaOpts `mappend` mempty {-                      ghcOptProfilingMode = toFlag True,-                      ghcOptHiSuffix      = toFlag "p_hi",-                      ghcOptObjSuffix     = toFlag "p_o",-                      ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi,-                      ghcOptHPCDir        = hpcdir Hpc.Prof-                    }--      sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                      ghcOptFPic        = toFlag True,-                      ghcOptHiSuffix    = toFlag "dyn_hi",-                      ghcOptObjSuffix   = toFlag "dyn_o",-                      ghcOptExtra       = toNubListR $ hcSharedOptions GHC libBi,-                      ghcOptHPCDir      = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,-                      ghcOptInputFiles     = toNubListR-                                             [libTargetDir </> x | x <- cObjs]-                   }-      replOpts    = vanillaOpts {-                      ghcOptExtra        = overNubListR-                                           Internal.filterGhciFlags $-                                           (ghcOptExtra vanillaOpts),-                      ghcOptNumJobs      = mempty-                    }-                    `mappend` linkerOpts-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                    }--      vanillaSharedOpts = vanillaOpts `mappend` mempty {-                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                      ghcOptDynHiSuffix  = toFlag "dyn_hi",-                      ghcOptDynObjSuffix = toFlag "dyn_o",-                      ghcOptHPCDir       = hpcdir Hpc.Dyn-                    }--  unless (forRepl || null (libModules lib)) $-    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)-           useDynToo = dynamicTooSupported &&-                       (forceVanillaLib || withVanillaLib lbi) &&-                       (forceSharedLib  || withSharedLib  lbi) &&-                       null (hcSharedOptions GHC libBi)-       if useDynToo-          then do-              runGhcProg vanillaSharedOpts-              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do-                    -- When the vanilla and shared library builds are done-                    -- in one pass, only one set of HPC module interfaces-                    -- are generated. This set should suffice for both-                    -- static and dynamically linked executables. We copy-                    -- the modules interfaces so they are available under-                    -- both ways.-                    copyDirectoryRecursive verbosity dynDir vanillaDir-                _ -> return ()-          else if isGhcDynamic-            then do shared;  vanilla-            else do vanilla; shared-       whenProfLib (runGhcProg profOpts)--  -- build any C sources-  unless (null (cSources libBi)) $ do-    info verbosity "Building C Sources..."-    sequence_-      [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo-                               lbi libBi clbi libTargetDir filename-               vanillaCcOpts = if isGhcDynamic-                               -- Dynamic GHC requires C sources to be built-                               -- with -fPIC for REPL to work. See #2207.-                               then baseCcOpts { ghcOptFPic = toFlag True }-                               else baseCcOpts-               profCcOpts    = vanillaCcOpts `mappend` mempty {-                                 ghcOptProfilingMode = toFlag True,-                                 ghcOptObjSuffix     = toFlag "p_o"-                               }-               sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                 ghcOptFPic        = toFlag True,-                                 ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                                 ghcOptObjSuffix   = toFlag "dyn_o"-                               }-               odir          = fromFlag (ghcOptObjDir vanillaCcOpts)-           createDirectoryIfMissingVerbose verbosity True odir-           let runGhcProgIfNeeded ccOpts = do-                 needsRecomp <- checkNeedsRecompilation filename ccOpts-                 when needsRecomp $ runGhcProg ccOpts-           runGhcProgIfNeeded vanillaCcOpts-           unless forRepl $-             whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)-           unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)-      | filename <- cSources libBi]--  -- 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.--  ifReplLib $ do-    when (null (libModules lib)) $ warn verbosity "No exposed modules"-    ifReplLib (runGhcProg replOpts)--  -- link:-  unless forRepl $ do-    info verbosity "Linking..."-    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))-                      (cSources libBi)-        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))-                      (cSources libBi)-        cid = compilerId (compiler lbi)-        vanillaLibFilePath = libTargetDir </> mkLibName           libName-        profileLibFilePath = libTargetDir </> mkProfLibName       libName-        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName-        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName-        libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-        sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName--    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     <- Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir objExtension True-    hProfObjs <--      if (withProfLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir ("p_" ++ objExtension) True-              else return []-    hSharedObjs <--      if (withSharedLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir ("dyn_" ++ objExtension) False-              else return []--    unless (null hObjs && null cObjs && null stubObjs) $ do-      rpaths <- getRPaths lbi clbi--      let staticObjectFiles =-                 hObjs-              ++ map (libTargetDir </>) cObjs-              ++ stubObjs-          profObjectFiles =-                 hProfObjs-              ++ map (libTargetDir </>) cProfObjs-              ++ stubProfObjs-          ghciObjFiles =-                 hObjs-              ++ map (libTargetDir </>) cObjs-              ++ stubObjs-          dynamicObjectFiles =-                 hSharedObjs-              ++ map (libTargetDir </>) cSharedObjs-              ++ stubSharedObjs-          -- After the relocation lib is created we invoke ghc -shared-          -- with the dependencies spelled out as -package arguments-          -- and ghc invokes the linker with the proper library paths-          ghcSharedLinkArgs =-              mempty {-                ghcOptShared             = toFlag True,-                ghcOptDynLinkMode        = toFlag GhcDynamicOnly,-                ghcOptInputFiles         = toNubListR dynamicObjectFiles,-                ghcOptOutputFile         = toFlag sharedLibFilePath,-                -- 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 < Version [7,8] [])-                                            then toFlag sharedLibInstallPath-                                            else mempty,-                ghcOptPackageKey         = toFlag (pkgKey lbi),-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi ,-                ghcOptLinkLibs           = toNubListR $ extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi,-                ghcOptLinkFrameworks     = toNubListR $ PD.frameworks libBi,-                ghcOptRPaths             = rpaths-              }--      info verbosity (show (ghcOptPackages ghcSharedLinkArgs))--      whenVanillaLib False $ do-        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles--      whenProfLib $ do-        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles--      whenGHCiLib $ do-        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-        Ld.combineObjectFiles verbosity ldProg-          ghciLibFilePath ghciObjFiles--      whenSharedLib False $-        runGhcProg ghcSharedLinkArgs---- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler-                 -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp packageDBs = do-  let replOpts = mempty {-        ghcOptMode       = toFlag GhcModeInteractive,-        ghcOptPackageDBs = packageDBs-        }-  checkPackageDbStack packageDBs-  (ghcProg, _) <- requireProgram verbosity ghcProgram conf-  runGHC verbosity ghcProg comp replOpts---- | Build an executable with GHC.----buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe = buildOrReplExe False-replExe  = buildOrReplExe True--buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do--  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let comp       = compiler lbi-      implInfo   = getImplInfo comp-      runGhcProg = runGHC verbosity ghcProg comp--  exeBi <- hackThreadedFlag verbosity-             comp (withProfExe lbi) (buildInfo exe)--  -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if takeExtension exeName' /= ('.':exeExtension)-                       then exeExtension-                       else "")--  let targetDir = (buildDir lbi) </> 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?--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'-        | otherwise = mempty--  -- build executables--  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath-  rpaths              <- getRPaths lbi clbi--  let isGhcDynamic        = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]-      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]-      cObjs         = map (`replaceExtension` objExtension) cSrcs-      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   = toNubListR-                        [ srcMainFile | isHaskellMain],-                      ghcOptInputModules = toNubListR-                        [ m | not isHaskellMain, m <- exeModules exe]-                    }-      staticOpts = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,-                      ghcOptHPCDir         = hpcdir Hpc.Vanilla-                   }-      profOpts   = baseOpts `mappend` mempty {-                      ghcOptProfilingMode  = toFlag True,-                      ghcOptHiSuffix       = toFlag "p_hi",-                      ghcOptObjSuffix      = toFlag "p_o",-                      ghcOptExtra          = toNubListR $ hcProfOptions GHC exeBi,-                      ghcOptHPCDir         = hpcdir Hpc.Prof-                    }-      dynOpts    = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,-                      ghcOptHiSuffix       = toFlag "dyn_hi",-                      ghcOptObjSuffix      = toFlag "dyn_o",-                      ghcOptExtra          = toNubListR $-                                             hcSharedOptions GHC exeBi,-                      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    = toNubListR $ PD.ldOptions exeBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,-                      ghcOptInputFiles     = toNubListR-                                             [exeDir </> x | x <- cObjs]-                    }-      dynLinkerOpts = mempty {-                      ghcOptRPaths         = rpaths-                   }-      replOpts   = baseOpts {-                      ghcOptExtra          = overNubListR-                                             Internal.filterGhciFlags-                                             (ghcOptExtra baseOpts)-                   }-                   -- For a normal compile we do separate invocations of ghc for-                   -- compiling as for linking. But for repl we have to do just-                   -- the one invocation, so that one has to include all the-                   -- linker stuff too, like -l flags and any .o files from C-                   -- files etc.-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeInteractive,-                      ghcOptOptimisation   = toFlag GhcNoOptimisation-                   }-      commonOpts  | withProfExe lbi = profOpts-                  | withDynExe  lbi = dynOpts-                  | otherwise       = staticOpts-      compileOpts | useDynToo = dynTooOpts-                  | otherwise = commonOpts-      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)--      -- 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 = EnableExtension TemplateHaskell `elem` allExtensions exeBi-      -- Should we use -dynamic-too instead of compiling twice?-      useDynToo = dynamicTooSupported && isGhcDynamic-                  && doingTH && withStaticExe-                  && null (hcSharedOptions GHC exeBi)-      compileTHOpts | isGhcDynamic = dynOpts-                    | otherwise    = staticOpts-      compileForTH-        | forRepl      = False-        | useDynToo    = False-        | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe)-        | otherwise    = doingTH && (withProfExe lbi || withDynExe lbi)--      linkOpts = commonOpts `mappend`-                 linkerOpts `mappend`-                 mempty { ghcOptLinkNoHsMain   = toFlag (not isHaskellMain) } `mappend`-                 (if withDynExe lbi then dynLinkerOpts else mempty)--  -- Build static/dynamic object files for TH, if needed.-  when compileForTH $-    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True-                             , ghcOptNumJobs = numJobs }--  unless forRepl $-    runGhcProg compileOpts { ghcOptNoLink  = toFlag True-                           , ghcOptNumJobs = numJobs }--  -- build any C sources-  unless (null cSrcs) $ do-   info verbosity "Building C Sources..."-   sequence_-     [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi-                         clbi exeDir filename) `mappend` mempty {-                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi-                                                       then GhcDynamicOnly-                                                       else GhcStaticOnly),-                       ghcOptProfilingMode = toFlag (withProfExe lbi)-                     }-              odir  = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          needsRecomp <- checkNeedsRecompilation filename opts-          when needsRecomp $ -            runGhcProg opts-     | filename <- cSrcs ]--  -- TODO: problem here is we need the .c files built first, so we can load them-  -- with ghci, but .c files can depend on .h files generated by ghc by ffi-  -- exports.-  when forRepl $ runGhcProg replOpts--  -- link:-  unless forRepl $ do-    info verbosity "Linking..."-    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }---- | Returns True if the modification date of the given source file is newer than--- the object file we last compiled for it, or if no object file exists yet.-checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool-checkNeedsRecompilation filename opts = filename `moreRecentFile` oname-    where oname = getObjectFileName filename opts---- | Finds the object file name of the given source file-getObjectFileName :: FilePath -> GhcOptions -> FilePath-getObjectFileName filename opts = oname-    where odir  = fromFlag (ghcOptObjDir opts)-          oext  = fromFlagOrDefault "o" (ghcOptObjSuffix opts)-          oname = odir </> replaceExtension filename oext---- | Calculate the RPATHs for the component we are building.------ Calculates relative RPATHs when 'relocatable' is set.-getRPaths :: LocalBuildInfo-          -> ComponentLocalBuildInfo -- ^ Component we are building-          -> IO (NubListR FilePath)-getRPaths lbi clbi | supportRPaths hostOS = do-    libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi-    let hostPref = case hostOS of-                     OSX -> "@loader_path"-                     _   -> "$ORIGIN"-        relPath p = if isRelative p then hostPref </> p else p-        rpaths    = toNubListR (map relPath libraryPaths)-    return rpaths-  where-    (Platform _ hostOS) = hostPlatform lbi--    -- 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     = 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 Ghcjs       = 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---- | 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 ]----- | 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-      comp        = compiler lbi-      vanillaArgs =-        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))-        `mappend` mempty {-          ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptPackageKey   = toFlag (pkgKey lbi),-          ghcOptInputModules = toNubListR $ exposedModules lib-        }-      sharedArgs = vanillaArgs `mappend` mempty {-                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                       ghcOptFPic        = toFlag True,-                       ghcOptHiSuffix    = toFlag "dyn_hi",-                       ghcOptObjSuffix   = toFlag "dyn_o",-                       ghcOptExtra       = toNubListR $ hcSharedOptions GHC libBi-                   }-      profArgs = vanillaArgs `mappend` mempty {-                     ghcOptProfilingMode = toFlag True,-                     ghcOptHiSuffix      = toFlag "p_hi",-                     ghcOptObjSuffix     = toFlag "p_o",-                     ghcOptExtra         = toNubListR $ hcProfOptions GHC libBi-                 }-      ghcArgs = if withVanillaLib lbi then vanillaArgs-           else if withSharedLib  lbi then sharedArgs-           else if withProfLib    lbi then profArgs-           else error "libAbiHash: Can't find an enabled library way"-  ---  (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  hash <- getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs)-  return (takeWhile (not . isSpace) hash)--componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions = Internal.componentGhcOptions---- -------------------------------------------------------------------------------- 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)-          when (stripExes lbi) $-            Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)-                           (dest <.> exeExtension)-  installBinary (binDir </> fixedExeBaseName)---- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic libraries-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do-  -- copy .hi files over:-  whenVanilla $ copyModuleFiles "hi"-  whenProf    $ copyModuleFiles "p_hi"-  whenShared  $ copyModuleFiles "dyn_hi"--  -- copy the built library files over:-  whenVanilla $ mapM_ (installOrdinary builtDir targetDir)       vanillaLibNames-  whenProf    $ mapM_ (installOrdinary builtDir targetDir)       profileLibNames-  whenGHCi    $ mapM_ (installOrdinary builtDir targetDir)       ghciLibNames-  whenShared  $ mapM_ (installShared   builtDir dynlibTargetDir) sharedLibNames--  where-    install isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True dstDir-      if isShared-        then do when (stripLibs lbi) $ Strip.stripLib verbosity-                                       (hostPlatform lbi) (withPrograms lbi) src-                installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst--    installOrdinary = install False-    installShared   = install True--    copyModuleFiles ext =-      findModuleFiles [builtDir] [ext] (libModules lib)-      >>= installOrdinaryFiles verbosity targetDir--    cid = compilerId (compiler lbi)-    libNames = componentLibraries clbi-    vanillaLibNames = map mkLibName              libNames-    profileLibNames = map mkProfLibName          libNames-    ghciLibNames    = map Internal.mkGHCiLibName libNames-    sharedLibNames  = map (mkSharedLibName cid)  libNames--    hasLib    = not $ null (libModules lib)-                   && null (cSources (libBuildInfo lib))-    whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi)-    whenGHCi    = when (hasLib && withGHCiLib    lbi)-    whenShared  = when (hasLib && withSharedLib  lbi)---- -------------------------------------------------------------------------------- Registering--hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcPkgProg-                                 , HcPkg.noPkgDbStack    = v < [6,9]-                                 , HcPkg.noVerboseFlag   = v < [6,11]-                                 , HcPkg.flagPackageConf = v < [7,5]-                                 , HcPkg.useSingleFileDb = v < [7,9]-                                 }-  where-    v               = versionBranch ver-    Just ghcPkgProg = lookupProgram ghcPkgProgram conf-    Just ver        = programVersion ghcPkgProg--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity-    packageDbs (Right installedPkgInfo)--pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath-pkgRoot verbosity lbi = pkgRoot'-   where-    pkgRoot' GlobalPackageDB =-      let Just ghcProg = lookupProgram ghcProgram (withPrograms lbi)-      in  fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)-    pkgRoot' UserPackageDB = do-      appDir <- getAppUserDataDirectory "ghc"-      let ver      = compilerVersion (compiler lbi)-          subdir   = System.Info.arch ++ '-':System.Info.os ++ '-':showVersion ver-          rootDir  = appDir </> subdir-      -- We must create the root directory for the user package database if it-      -- does not yet exists. Otherwise '${pkgroot}' will resolve to a-      -- directory at the time of 'ghc-pkg register', and registration will-      -- fail.-      createDirectoryIfMissing True rootDir-      return rootDir-    pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)---- -------------------------------------------------------------------------------- Utils--isDynamic :: Compiler -> Bool-isDynamic = Internal.ghcLookupProperty "GHC Dynamic"--supportsDynamicToo :: Compiler -> Bool-supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
− Distribution/Simple/GHC/IPI641.hs 
@@ -1,106 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.IPI641--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-----module Distribution.Simple.GHC.IPI641 (-    InstalledPackageInfo(..),-    toCurrent,-  ) where--import qualified Distribution.InstalledPackageInfo as Current-import qualified Distribution.Package as Current hiding (depends, installedPackageId)-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{} =-  let pid = convertPackageId (package ipi)-      mkExposedModule m = Current.ExposedModule m Nothing Nothing-  in Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = pid,-    Current.packageKey         = Current.OldPackageKey pid,-    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 (mkExposedModule . convertModuleName) (exposedModules ipi),-    Current.instantiatedWith   = [],-    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,-    Current.importDirs         = importDirs ipi,-    Current.libraryDirs        = libraryDirs ipi,-    Current.dataDir            = "",-    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.ccOptions          = ccOptions ipi,-    Current.ldOptions          = ldOptions ipi,-    Current.frameworkDirs      = frameworkDirs ipi,-    Current.frameworks         = frameworks ipi,-    Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi,-    Current.pkgRoot            = Nothing-  }
− Distribution/Simple/GHC/IPI642.hs 
@@ -1,141 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.GHC.IPI642--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable-----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, installedPackageId)-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{} =-  let pid = convertPackageId (package ipi)-      mkExposedModule m = Current.ExposedModule m Nothing Nothing-  in Current.InstalledPackageInfo {-    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),-    Current.sourcePackageId    = pid,-    Current.packageKey         = Current.OldPackageKey pid,-    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 (mkExposedModule . convertModuleName) (exposedModules ipi),-    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),-    Current.instantiatedWith   = [],-    Current.trusted            = Current.trusted Current.emptyInstalledPackageInfo,-    Current.importDirs         = importDirs ipi,-    Current.libraryDirs        = libraryDirs ipi,-    Current.dataDir            = "",-    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.ccOptions          = ccOptions ipi,-    Current.ldOptions          = ldOptions ipi,-    Current.frameworkDirs      = frameworkDirs ipi,-    Current.frameworks         = frameworks ipi,-    Current.haddockInterfaces  = haddockInterfaces ipi,-    Current.haddockHTMLs       = haddockHTMLs ipi,-    Current.pkgRoot            = Nothing-  }
− Distribution/Simple/GHC/ImplInfo.hs 
@@ -1,108 +0,0 @@--------------------------------------------------------------------------------- |--- 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, lhcVersionImplInfo-        ) where--import Distribution.Simple.Compiler-  ( Compiler(..), CompilerFlavor(..)-  , compilerFlavor, compilerVersion, compilerCompatVersion )-import Distribution.Version ( 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-  { hasCcOdirBug         :: Bool -- ^ bug in -odir handling for C compilations.-  , flagInfoLanguages    :: Bool -- ^ --info and --supported-languages flags-  , fakeRecordPuns       :: Bool -- ^ use -XRecordPuns for NamedFieldPuns-  , flagStubdir          :: Bool -- ^ -stubdir flag supported-  , flagOutputDir        :: Bool -- ^ -outputdir flag supported-  , noExtInSplitSuffix   :: Bool -- ^ split-obj suffix does not contain p_o ext-  , flagFfiIncludes      :: Bool -- ^ -#include on command line for FFI includes-  , flagBuildingCabalPkg :: Bool -- ^ -fbuilding-cabal-package flag supported-  , flagPackageId        :: Bool -- ^ -package-id / -package flags supported-  , separateGccMingw     :: Bool -- ^ mingw and gcc are in separate directories-  , supportsHaskell2010  :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags-  , reportsNoExt         :: Bool -- ^ --supported-languages gives Ext and NoExt-  , alwaysNondecIndent   :: Bool -- ^ NondecreasingIndentation is always on-  , flagGhciScript       :: Bool -- ^ -ghci-script flag supported-  , flagPackageConf      :: Bool -- ^ use package-conf instead of package-db-  , flagDebugInfo        :: Bool -- ^ -g flag supported-  }--getImplInfo :: Compiler -> GhcImplInfo-getImplInfo comp =-  case compilerFlavor comp of-    GHC   -> ghcVersionImplInfo (compilerVersion comp)-    LHC   -> lhcVersionImplInfo (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, LHC)" ++-                    ", but found " ++ show x)--ghcVersionImplInfo :: Version -> GhcImplInfo-ghcVersionImplInfo (Version v _) = GhcImplInfo-  { hasCcOdirBug         = v <  [6,4,1]-  , flagInfoLanguages    = v >= [6,7]-  , fakeRecordPuns       = v >= [6,8] && v < [6,10]-  , flagStubdir          = v >= [6,8]-  , flagOutputDir        = v >= [6,10]-  , noExtInSplitSuffix   = v <  [6,11]-  , flagFfiIncludes      = v <  [6,11]-  , flagBuildingCabalPkg = v >= [6,11]-  , flagPackageId        = v >  [6,11]-  , separateGccMingw     = v <  [6,12]-  , supportsHaskell2010  = v >= [7]-  , reportsNoExt         = v >= [7]-  , alwaysNondecIndent   = v <  [7,1]-  , flagGhciScript       = v >= [7,2]-  , flagPackageConf      = v <  [7,5]-  , flagDebugInfo        = v >= [7,10]-  }--ghcjsVersionImplInfo :: Version -> Version -> GhcImplInfo-ghcjsVersionImplInfo _ghcjsVer _ghcVer = GhcImplInfo-  { hasCcOdirBug         = False-  , flagInfoLanguages    = True-  , fakeRecordPuns       = False-  , flagStubdir          = True-  , flagOutputDir        = True-  , noExtInSplitSuffix   = False-  , flagFfiIncludes      = False-  , flagBuildingCabalPkg = True-  , flagPackageId        = True-  , separateGccMingw     = False-  , supportsHaskell2010  = True-  , reportsNoExt         = True-  , alwaysNondecIndent   = False-  , flagGhciScript       = True-  , flagPackageConf      = False-  , flagDebugInfo        = False-  }--lhcVersionImplInfo :: Version -> GhcImplInfo-lhcVersionImplInfo = ghcVersionImplInfo
− Distribution/Simple/GHC/Internal.hs 
@@ -1,492 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- 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,-        componentGhcOptions,-        mkGHCiLibName,-        filterGhciFlags,-        ghcLookupProperty,-        getHaskellObjects,-        mkGhcOptPackages,-        substTopDir,-        checkPackageDbEnvVar- ) where--import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) )-import Distribution.Package-         ( InstalledPackageId, PackageId )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.PackageDescription as PD-         ( BuildInfo(..), Library(..), libModules-         , hcOptions, usedExtensions, ModuleRenaming, lookupRenaming )-import Distribution.Compat.Exception ( catchExit, catchIO )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..), OptimisationLevel(..) )-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-         ( toFlag )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)-         , rawSystemProgram, rawSystemProgramStdout, programPath-         , addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram-         , getProgramOutput )-import Distribution.Simple.Program.Types ( suppressOverrideArgs )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , LibraryName(..) )-import Distribution.Simple.Utils-import Distribution.Simple.BuildPaths-import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple )-import Distribution.Text ( display, simpleParse )-import Distribution.Utils.NubList ( toNubListR )-import Distribution.Verbosity-import Language.Haskell.Extension-         ( Language(..), Extension(..), KnownExtension(..) )--import qualified Data.Map as M-import Data.Char                ( isSpace )-import Data.Maybe               ( fromMaybe, maybeToList, isJust )-import Control.Monad            ( unless, when )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif-import System.Directory         ( getDirectoryContents, getTemporaryDirectory )-import System.Environment       ( getEnv )-import System.FilePath          ( (</>), (<.>), takeExtension, takeDirectory )-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-                   -> M.Map String String-                   -> ProgramConfiguration-                   -> ProgramConfiguration-configureToolchain implInfo ghcProg ghcInfo =-    addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram extraGccPath,-      programPostConf     = configureGcc-    }-  . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram extraLdPath,-      programPostConf     = configureLd-    }-  . addKnownProgram arProgram {-      programFindLocation = findProg arProgram extraArPath-    }-  . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgram extraStripPath-    }-  where-    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-    binPrefix   = ""--    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]-    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]-                                 | otherwise = mbDir-      where-        mbDir = maybeToList . fmap takeDirectory $ mbPath--    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir-    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir-    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir-    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir--    -- on Windows finding and configuring ghc's gcc & binutils is a bit special-    (windowsExtraGccDir, windowsExtraLdDir,-     windowsExtraArDir, windowsExtraStripDir)-      | separateGccMingw implInfo = (baseDir, libDir, libDir, libDir)-      | otherwise                 = -- GHC >= 6.12-          let b = mingwBinDir </> binPrefix-          in  (b, b, b, b)--    findProg :: Program -> [FilePath]-             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)-    findProg prog extraPath v searchpath =-        programFindLocation prog v searchpath'-      where-        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath--    -- Read tool locations from the 'ghc --info' output. Useful when-    -- cross-compiling.-    mbGccLocation   = M.lookup "C compiler command" ghcInfo-    mbLdLocation    = M.lookup "ld command" ghcInfo-    mbArLocation    = M.lookup "ar command" ghcInfo-    mbStripLocation = M.lookup "strip command" ghcInfo--    ccFlags        = getFlags "C compiler flags"-    gccLinkerFlags = getFlags "Gcc Linker flags"-    ldLinkerFlags  = getFlags "Ld Linker flags"--    getFlags key = case M.lookup key ghcInfo of-                   Nothing -> []-                   Just flags ->-                       case reads flags of-                       [(args, "")] -> args-                       _ -> [] -- XXX Should should be an error really--    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureGcc v gccProg = do-      gccProg' <- configureGcc' v gccProg-      return gccProg' {-        programDefaultArgs = programDefaultArgs gccProg'-                             ++ ccFlags ++ gccLinkerFlags-      }--    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    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 {}-           | separateGccMingw implInfo ->-               return gccProg { programDefaultArgs = ["-B" ++ libDir,-                                                      "-I" ++ includeDir] }-          _ -> return gccProg-      | otherwise = \_ gccProg -> return gccProg--    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd v ldProg = do-      ldProg' <- configureLd' v ldProg-      return ldProg' {-        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags-      }--    -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd' verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() { return 0; }"-               hClose testchnd; hClose testohnd-               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 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-  | supportsHaskell2010 implInfo = return [(Haskell98,   "-XHaskell98")-                                          ,(Haskell2010, "-XHaskell2010")]-  | otherwise                    = return [(Haskell98,   "")]--getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram-           -> IO [(String, String)]-getGhcInfo verbosity implInfo ghcProg-  | flagInfoLanguages implInfo = do-      xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)-                 ["--info"]-      case reads xs of-        [(i, ss)]-          | all isSpace ss ->-              return i-        _ ->-          die "Can't parse --info output of GHC"-  | otherwise =-      return []--getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram-              -> IO [(Extension, String)]-getExtensions verbosity implInfo ghcProg-  | flagInfoLanguages implInfo = 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, "-X" ++ display ext)-                      | Just ext <- map simpleParse extStrs ]-        extensions1 = if fakeRecordPuns implInfo-                      then -- ghc-6.8 introduced RecordPuns however it-                           -- should have been NamedFieldPuns. We now-                           -- encourage packages to use NamedFieldPuns-                           -- so for compatibility 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 alwaysNondecIndent implInfo-                      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---- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags-oldLanguageExtensions :: [(Extension, String)]-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)-    ]--componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo-                      -> BuildInfo -> ComponentLocalBuildInfo-                      -> FilePath -> FilePath-                      -> GhcOptions-componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename =-    mempty {-      ghcOptVerbosity      = toFlag verbosity,-      ghcOptMode           = toFlag GhcModeCompile,-      ghcOptInputFiles     = toNubListR [filename],--      ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]-                                          ++ PD.includeDirs bi,-      ghcOptPackageDBs     = withPackageDB lbi,-      ghcOptPackages       = toNubListR $ mkGhcOptPackages clbi,-      ghcOptCcOptions      = toNubListR $-                             (case withOptimization lbi of-                                  NoOptimisation -> []-                                  _              -> ["-O2"]) ++-                             (case withDebugInfo lbi of-                                  NoDebugInfo   -> []-                                  MinimalDebugInfo -> ["-g1"]-                                  NormalDebugInfo  -> ["-g"]-                                  MaximalDebugInfo -> ["-g3"]) ++-                                  PD.ccOptions bi,-      ghcOptObjDir         = toFlag odir-    }-  where-    odir | hasCcOdirBug implInfo = pref </> takeDirectory filename-         | otherwise             = pref-         -- ghc 6.4.0 had a bug in -odir handling for C compilations.--componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-    mempty {-      ghcOptVerbosity       = toFlag verbosity,-      ghcOptHideAllPackages = toFlag True,-      ghcOptCabal           = toFlag True,-      ghcOptPackageDBs      = withPackageDB lbi,-      ghcOptPackages        = toNubListR $ mkGhcOptPackages clbi,-      ghcOptSplitObjs       = toFlag (splitObjs lbi),-      ghcOptSourcePathClear = toFlag True,-      ghcOptSourcePath      = toNubListR $ [odir] ++ (hsSourceDirs bi)-                                           ++ [autogenModulesDir lbi],-      ghcOptCppIncludePath  = toNubListR $ [autogenModulesDir lbi, odir]-                                           ++ PD.includeDirs bi,-      ghcOptCppOptions      = toNubListR $ cppOptions bi,-      ghcOptCppIncludes     = toNubListR $-                              [autogenModulesDir lbi </> cppHeaderName],-      ghcOptFfiIncludes     = toNubListR $ PD.includes bi,-      ghcOptObjDir          = toFlag odir,-      ghcOptHiDir           = toFlag odir,-      ghcOptStubDir         = toFlag odir,-      ghcOptOutputDir       = toFlag odir,-      ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),-      ghcOptDebugInfo       = toGhcDebugInfo (withDebugInfo lbi),-      ghcOptExtra           = toNubListR $ hcOptions GHC bi,-      ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),-      -- Unsupported extensions have already been checked by configure-      ghcOptExtensions      = toNubListR $ usedExtensions bi,-      ghcOptExtensionMap    = M.fromList . compilerExtensions $ (compiler lbi)-    }-  where-    toGhcOptimisation NoOptimisation      = mempty --TODO perhaps override?-    toGhcOptimisation NormalOptimisation  = toFlag GhcNormalOptimisation-    toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation--    -- GHC doesn't support debug info levels yet.-    toGhcDebugInfo NoDebugInfo      = mempty-    toGhcDebugInfo MinimalDebugInfo = toFlag True-    toGhcDebugInfo NormalDebugInfo  = toFlag True-    toGhcDebugInfo MaximalDebugInfo = toFlag True---- | 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 :: LibraryName -> String-mkGHCiLibName (LibraryName lib) = lib <.> "o"--ghcLookupProperty :: String -> Compiler -> Bool-ghcLookupProperty prop comp =-  case M.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-                  -> FilePath -> String -> Bool -> IO [FilePath]-getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs-  | splitObjs lbi && allow_split_objs = do-        let splitSuffix = if   noExtInSplitSuffix implInfo-                          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 ]--mkGhcOptPackages :: ComponentLocalBuildInfo-                 -> [(InstalledPackageId, PackageId, ModuleRenaming)]-mkGhcOptPackages clbi =-  map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))-      (componentPackageDeps clbi)--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---- 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 :: String -> String -> IO ()-checkPackageDbEnvVar compilerName packagePathEnvVar = do-    mPP <- lookupEnv packagePathEnvVar-    when (isJust mPP) $ do-        mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"-        unless (mPP == mcsPP) abort-    where-        lookupEnv :: String -> IO (Maybe String)-        lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)-        abort =-            die $ "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)."
− Distribution/Simple/GHCJS.hs 
@@ -1,904 +0,0 @@-{-# LANGUAGE CPP #-}--module Distribution.Simple.GHCJS (-        configure, getInstalledPackages, getPackageDBContents,-        buildLib, buildExe,-        replLib, replExe,-        startInterpreter,-        installLib, installExe,-        libAbiHash,-        hcPkgInfo,-        registerPackage,-        componentGhcOptions,-        getLibDir,-        isDynamic,-        getGlobalPackageDB,-        runCmd-  ) where--import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo )-import qualified Distribution.Simple.GHC.Internal as Internal-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, exeModules-         , hcOptions, hcProfOptions, hcSharedOptions-         , allExtensions )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-                                ( InstalledPackageInfo_(..) )-import Distribution.Simple.PackageIndex ( InstalledPackageIndex )-import qualified Distribution.Simple.PackageIndex as PackageIndex-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , LibraryName(..) )-import qualified Distribution.Simple.Hpc as Hpc-import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath-         , rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput-         , requireProgramVersion, requireProgram-         , userMaybeSpecifyPath, programPath-         , lookupProgram, addKnownPrograms-         , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram-         , ldProgram, haddockProgram, 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 qualified Distribution.Simple.Program.Strip as Strip-import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup-         ( toFlag, fromFlag, configCoverage, configDistPref )-import qualified Distribution.Simple.Setup as Cabal-        ( Flag(..) )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..)-         , PackageDB(..), PackageDBStack, AbiTag(..) )-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.System-         ( Platform(..) )-import Distribution.Verbosity-import Distribution.Utils.NubList-         ( overNubListR, toNubListR )-import Distribution.Text ( display )-import Language.Haskell.Extension ( Extension(..)-                                  , KnownExtension(..))--import Control.Monad            ( unless, when )-import Data.Char                ( isSpace )-import qualified Data.Map as M  ( fromList  )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif-import System.Directory         ( doesFileExist )-import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension,-                                  splitExtension )--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration-          -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity hcPath hcPkgPath conf0 = do-  (ghcjsProg, ghcjsVersion, conf1) <--    requireProgramVersion verbosity ghcjsProgram-      (orLaterVersion (Version [0,1] []))-      (userMaybeSpecifyPath "ghcjs" hcPath conf0)-  Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)-  let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion--  -- This is slightly tricky, we have to configure ghcjs first, then we use the-  -- location of ghcjs to help find ghcjs-pkg in the case that the user did not-  -- specify the location of ghc-pkg directly:-  (ghcjsPkgProg, ghcjsPkgVersion, conf2) <--    requireProgramVersion verbosity ghcjsPkgProgram {-      programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg-    }-    anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1)--  Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion-                                  verbosity (programPath ghcjsPkgProg)--  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die $-       "Version mismatch between ghcjs and ghcjs-pkg: "-    ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " "-    ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion--  when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die $-       "Version mismatch between ghcjs and ghcjs-pkg: "-    ++ programPath ghcjsProg-    ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " "-    ++ programPath ghcjsPkgProg-    ++ " was built with GHC version " ++ display ghcjsPkgVersion--  -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc-  let hsc2hsProgram' =-        hsc2hsProgram { programFindLocation =-                          guessHsc2hsFromGhcjsPath ghcjsProg }-      c2hsProgram' =-        c2hsProgram { programFindLocation =-                          guessC2hsFromGhcjsPath ghcjsProg }--      haddockProgram' =-        haddockProgram { programFindLocation =-                          guessHaddockFromGhcjsPath ghcjsProg }-      conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2--  languages  <- Internal.getLanguages  verbosity implInfo ghcjsProg-  extensions <- Internal.getExtensions verbosity implInfo ghcjsProg--  ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg-  let ghcInfoMap = M.fromList ghcInfo--  let comp = Compiler {-        compilerId         = CompilerId GHCJS ghcjsVersion,-        compilerAbiTag     = AbiTag $-          "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion),-        compilerCompat     = [CompilerId GHC ghcjsGhcVersion],-        compilerLanguages  = languages,-        compilerExtensions = extensions,-        compilerProperties = ghcInfoMap-      }-      compPlatform = Internal.targetPlatform ghcInfo-  -- configure gcc and ld-  let conf4 = if ghcjsNativeToo comp-                     then Internal.configureToolchain implInfo-                            ghcjsProg ghcInfoMap conf3-                     else conf3-  return (comp, compPlatform, conf4)--ghcjsNativeToo :: Compiler -> Bool-ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"--guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity-                           -> ProgramSearchPath -> IO (Maybe FilePath)-guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram--guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity-                         -> ProgramSearchPath -> IO (Maybe FilePath)-guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram--guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity-                       -> ProgramSearchPath -> IO (Maybe FilePath)-guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram--guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity-                          -> ProgramSearchPath -> IO (Maybe FilePath)-guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram--guessToolFromGhcjsPath :: Program -> ConfiguredProgram-                       -> Verbosity -> ProgramSearchPath-                       -> IO (Maybe FilePath)-guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath-  = do let toolname          = programName tool-           path              = programPath ghcjsProg-           dir               = takeDirectory path-           versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> toolname <.> exeExtension-           guessGhcjsVersioned = dir </> (toolname ++ "-ghcjs" ++ versionSuffix)-                                 <.> exeExtension-           guessGhcjs        = dir </> (toolname ++ "-ghcjs")-                               <.> exeExtension-           guessVersioned    = dir </> (toolname ++ versionSuffix) <.> exeExtension-           guesses | null versionSuffix = [guessGhcjs, guessNormal]-                   | otherwise          = [guessGhcjsVersioned,-                                           guessGhcjs,-                                           guessVersioned,-                                           guessNormal]-       info verbosity $ "looking for tool " ++ toolname-         ++ " near compiler in " ++ dir-       exists <- mapM 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-                      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 a single package DB, return all installed packages.-getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getPackageDBContents verbosity packagedb conf = do-  pkgss <- getInstalledPackages' verbosity [packagedb] conf-  toPackageIndex verbosity pkgss conf---- | Given a package DB stack, return all installed packages.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbEnvVar-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' verbosity packagedbs conf-  index <- toPackageIndex verbosity pkgss conf-  return $! index--toPackageIndex :: Verbosity-               -> [(PackageDB, [InstalledPackageInfo])]-               -> ProgramConfiguration-               -> IO InstalledPackageIndex-toPackageIndex verbosity pkgss conf = 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-    Just ghcjsProg = lookupProgram ghcjsProgram conf--checkPackageDbEnvVar :: IO ()-checkPackageDbEnvVar =-    Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH"--checkPackageDbStack :: PackageDBStack -> IO ()-checkPackageDbStack (GlobalPackageDB:rest)-  | GlobalPackageDB `notElem` rest = return ()-checkPackageDbStack rest-  | GlobalPackageDB `notElem` rest =-  die $ "With current ghc versions the global package db is always used "-     ++ "and must be listed first. This ghc limitation may be lifted in "-     ++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"-checkPackageDbStack _ =-  die $ "If the global package db is specified, it must be "-     ++ "specified first and cannot be specified multiple times"--getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration-                      -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' verbosity packagedbs conf =-  sequence-    [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb-         return (packagedb, pkgs)-    | packagedb <- packagedbs ]--getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath-getLibDir verbosity lbi =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcjsProgram-     (withPrograms lbi) ["--print-libdir"]--getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath-getLibDir' verbosity ghcjsProg =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"]---- | Return the 'FilePath' to the global GHC package database.-getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath-getGlobalPackageDB verbosity ghcjsProg =-    (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdout verbosity ghcjsProg ["--print-global-package-db"]--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"--buildLib, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription-                  -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo-                  -> IO ()-buildLib = buildOrReplLib False-replLib  = buildOrReplLib True--buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Library            -> ComponentLocalBuildInfo -> IO ()-buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"-  let libTargetDir = buildDir lbi-      whenVanillaLib forceVanilla =-        when (not forRepl && (forceVanilla || withVanillaLib lbi))-      whenProfLib = when (not forRepl && withProfLib lbi)-      whenSharedLib forceShared =-        when (not forRepl &&  (forceShared || withSharedLib lbi))-      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)-      ifReplLib = when forRepl-      comp = compiler lbi-      implInfo = getImplInfo comp-      hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n)))-                       (instantiatedWith lbi)-      nativeToo = ghcjsNativeToo comp--  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  let runGhcjsProg        = runGHC verbosity ghcjsProg comp-      libBi               = libBuildInfo lib-      isGhcjsDynamic      = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      doingTH = EnableExtension TemplateHaskell `elem` allExtensions 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 = fromFlag $ configCoverage $ configFlags lbi-      -- Component name. Not 'libName' because that has the "HS" prefix-      -- that GHC gives Haskell libraries.-      cname = display $ PD.package $ localPkgDescr lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname-        | otherwise = mempty--  createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive-  -- modules?-  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)-      jsSrcs      = jsSources libBi-      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir-      linkJsLibOpts = mempty {-                        ghcOptExtra = toNubListR $-                          [ "-link-js-lib"     , (\(LibraryName l) -> l) libName-                          , "-js-lib-outputdir", libTargetDir ] ++-                          concatMap (\x -> ["-js-lib-src",x]) jsSrcs-                      }-      vanillaOptsNoJsLib = baseOpts `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptNumJobs      = numJobs,-                      ghcOptPackageKey   = toFlag (pkgKey lbi),-                      ghcOptSigOf        = hole_insts,-                      ghcOptInputModules = toNubListR $ libModules lib,-                      ghcOptHPCDir       = hpcdir Hpc.Vanilla-                    }-      vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts--      profOpts    = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {-                        ghcOptProfilingMode = toFlag True,-                        ghcOptExtra         = toNubListR $-                                              ghcjsProfOptions libBi,-                        ghcOptHPCDir        = hpcdir Hpc.Prof-                      }-      sharedOpts  = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {-                        ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                        ghcOptFPic        = toFlag True,-                        ghcOptExtra       = toNubListR $-                                            ghcjsSharedOptions libBi,-                        ghcOptHPCDir      = hpcdir Hpc.Dyn-                      }-      linkerOpts = mempty {-                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions libBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs libBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs libBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,-                      ghcOptInputFiles     =-                        toNubListR $ [libTargetDir </> x | x <- cObjs] ++ jsSrcs-                   }-      replOpts    = vanillaOptsNoJsLib {-                      ghcOptExtra        = overNubListR-                                           Internal.filterGhciFlags-                                           (ghcOptExtra vanillaOpts),-                      ghcOptNumJobs      = mempty-                    }-                    `mappend` linkerOpts-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeInteractive,-                      ghcOptOptimisation = toFlag GhcNoOptimisation-                    }--      vanillaSharedOpts = vanillaOpts `mappend`-                            mempty {-                              ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,-                              ghcOptDynHiSuffix  = toFlag "dyn_hi",-                              ghcOptDynObjSuffix = toFlag "dyn_o",-                              ghcOptHPCDir       = hpcdir Hpc.Dyn-                            }--  unless (forRepl || (null (libModules lib) && 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 (ghcjsSharedOptions libBi)-       if useDynToo-          then do-              runGhcjsProg vanillaSharedOpts-              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of-                (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do-                    -- When the vanilla and shared library builds are done-                    -- in one pass, only one set of HPC module interfaces-                    -- are generated. This set should suffice for both-                    -- static and dynamically linked executables. We copy-                    -- the modules interfaces so they are available under-                    -- both ways.-                    copyDirectoryRecursive verbosity dynDir vanillaDir-                _ -> return ()-          else if isGhcjsDynamic-            then do shared;  vanilla-            else do vanilla; shared-       whenProfLib (runGhcjsProg profOpts)--  -- build any C sources-  unless (null (cSources libBi) || not nativeToo) $ do-     info verbosity "Building C Sources..."-     sequence_-       [ do let vanillaCcOpts =-                  (Internal.componentCcGhcOptions verbosity implInfo-                     lbi libBi clbi libTargetDir filename)-                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-            runGhcjsProg vanillaCcOpts-            whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts)-            whenProfLib (runGhcjsProg 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.-  unless (null (libModules lib)) $-     ifReplLib (runGhcjsProg replOpts)--  -- link:-  when (nativeToo && not forRepl) $ do-    info verbosity "Linking..."-    let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))-                      (cSources libBi)-        cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))-                      (cSources libBi)-        cid = compilerId (compiler lbi)-        vanillaLibFilePath = libTargetDir </> mkLibName            libName-        profileLibFilePath = libTargetDir </> mkProfLibName        libName-        sharedLibFilePath  = libTargetDir </> mkSharedLibName cid  libName-        ghciLibFilePath    = libTargetDir </> Internal.mkGHCiLibName libName--    hObjs     <- Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir objExtension True-    hProfObjs <--      if (withProfLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir ("p_" ++ objExtension) True-              else return []-    hSharedObjs <--      if (withSharedLib lbi)-              then Internal.getHaskellObjects implInfo lib lbi-                      libTargetDir ("dyn_" ++ objExtension) False-              else return []--    unless (null hObjs && null cObjs) $ do--      let staticObjectFiles =-                 hObjs-              ++ map (libTargetDir </>) cObjs-          profObjectFiles =-                 hProfObjs-              ++ map (libTargetDir </>) cProfObjs-          ghciObjFiles =-                 hObjs-              ++ map (libTargetDir </>) cObjs-          dynamicObjectFiles =-                 hSharedObjs-              ++ map (libTargetDir </>) cSharedObjs-          -- 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,-                ghcOptPackageKey         = toFlag (pkgKey lbi),-                ghcOptNoAutoLinkPackages = toFlag True,-                ghcOptPackageDBs         = withPackageDB lbi,-                ghcOptPackages           = toNubListR $-                                           Internal.mkGhcOptPackages clbi,-                ghcOptLinkLibs           = toNubListR $ extraLibs libBi,-                ghcOptLinkLibPath        = toNubListR $ extraLibDirs libBi-              }--      whenVanillaLib False $ do-        Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles--      whenProfLib $ do-        Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles--      whenGHCiLib $ do-        (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)-        Ld.combineObjectFiles verbosity ldProg-          ghciLibFilePath ghciObjFiles--      whenSharedLib False $-        runGhcjsProg ghcSharedLinkArgs---- | Start a REPL without loading any source files.-startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler-                 -> PackageDBStack -> IO ()-startInterpreter verbosity conf comp packageDBs = do-  let replOpts = mempty {-        ghcOptMode       = toFlag GhcModeInteractive,-        ghcOptPackageDBs = packageDBs-        }-  checkPackageDbStack packageDBs-  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf-  runGHC verbosity ghcjsProg comp replOpts--buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)-                  -> PackageDescription -> LocalBuildInfo-                  -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe = buildOrReplExe False-replExe  = buildOrReplExe True--buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)-               -> PackageDescription -> LocalBuildInfo-               -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi-  exe@Executable { exeName = exeName', modulePath = modPath } clbi = do--  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  let comp         = compiler lbi-      implInfo     = getImplInfo comp-      runGhcjsProg = runGHC verbosity ghcjsProg comp-      exeBi        = buildInfo exe--  -- exeNameReal, the name that GHC really uses (with .exe on Windows)-  let exeNameReal = exeName' <.>-                    (if takeExtension exeName' /= ('.':exeExtension)-                       then exeExtension-                       else "")--  let targetDir = (buildDir lbi) </> 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?--  -- Determine if program coverage should be enabled and if so, what-  -- '-hpcdir' should be.-  let isCoverageEnabled = fromFlag $ configCoverage $ configFlags lbi-      distPref = fromFlag $ configDistPref $ configFlags lbi-      hpcdir way-        | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName'-        | otherwise = mempty--  -- build executables--  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath-  let isGhcjsDynamic      = isDynamic comp-      dynamicTooSupported = supportsDynamicToo comp-      buildRunner = case clbi of-                       ExeComponentLocalBuildInfo {} -> False-                       _                             -> True-      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]-      jsSrcs        = jsSources exeBi-      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]-      cObjs         = map (`replaceExtension` objExtension) cSrcs-      nativeToo     = ghcjsNativeToo comp-      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)-                    `mappend` mempty {-                      ghcOptMode         = toFlag GhcModeMake,-                      ghcOptInputFiles   = toNubListR $-                        [ srcMainFile | isHaskellMain],-                      ghcOptInputModules = toNubListR $-                        [ m | not isHaskellMain, m <- exeModules exe],-                      ghcOptExtra =-                        if buildRunner then toNubListR ["-build-runner"]-                                       else mempty-                    }-      staticOpts = baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticOnly,-                      ghcOptHPCDir         = hpcdir Hpc.Vanilla-                   }-      profOpts   = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty {-                      ghcOptProfilingMode  = toFlag True,-                      ghcOptExtra          = toNubListR $ ghcjsProfOptions exeBi,-                      ghcOptHPCDir         = hpcdir Hpc.Prof-                    }-      dynOpts    = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,-                      ghcOptExtra          = toNubListR $-                                             ghcjsSharedOptions exeBi,-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty {-                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,-                      ghcOptHPCDir         = hpcdir Hpc.Dyn-                    }-      linkerOpts = mempty {-                      ghcOptLinkOptions    = toNubListR $ PD.ldOptions exeBi,-                      ghcOptLinkLibs       = toNubListR $ extraLibs exeBi,-                      ghcOptLinkLibPath    = toNubListR $ extraLibDirs exeBi,-                      ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,-                      ghcOptInputFiles     = toNubListR $-                                             [exeDir </> x | x <- cObjs] ++ jsSrcs-                   }-      replOpts   = baseOpts {-                      ghcOptExtra          = overNubListR-                                             Internal.filterGhciFlags-                                             (ghcOptExtra baseOpts)-                   }-                   -- For a normal compile we do separate invocations of ghc for-                   -- compiling as for linking. But for repl we have to do just-                   -- the one invocation, so that one has to include all the-                   -- linker stuff too, like -l flags and any .o files from C-                   -- files etc.-                   `mappend` linkerOpts-                   `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeInteractive,-                      ghcOptOptimisation   = toFlag GhcNoOptimisation-                   }-      commonOpts  | withProfExe lbi = profOpts-                  | withDynExe  lbi = dynOpts-                  | otherwise       = staticOpts-      compileOpts | useDynToo = dynTooOpts-                  | otherwise = commonOpts-      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)--      -- 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 = EnableExtension TemplateHaskell `elem` allExtensions exeBi-      -- Should we use -dynamic-too instead of compiling twice?-      useDynToo = dynamicTooSupported && isGhcjsDynamic-                  && doingTH && withStaticExe && null (ghcjsSharedOptions exeBi)-      compileTHOpts | isGhcjsDynamic = dynOpts-                    | otherwise      = staticOpts-      compileForTH-        | forRepl      = False-        | useDynToo    = False-        | isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe)-        | otherwise      = doingTH && (withProfExe lbi || withDynExe lbi)--      linkOpts = commonOpts `mappend`-                 linkerOpts `mappend` mempty {-                      ghcOptLinkNoHsMain   = toFlag (not isHaskellMain)-                 }--  -- Build static/dynamic object files for TH, if needed.-  when compileForTH $-    runGhcjsProg compileTHOpts { ghcOptNoLink  = toFlag True-                               , ghcOptNumJobs = numJobs }--  unless forRepl $-    runGhcjsProg compileOpts { ghcOptNoLink  = toFlag True-                             , ghcOptNumJobs = numJobs }--  -- build any C sources-  unless (null cSrcs || not nativeToo) $ do-   info verbosity "Building C Sources..."-   sequence_-     [ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi-                         clbi exeDir filename) `mappend` mempty {-                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi-                                                       then GhcDynamicOnly-                                                       else GhcStaticOnly),-                       ghcOptProfilingMode = toFlag (withProfExe lbi)-                     }-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          runGhcjsProg 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.-  when forRepl $ runGhcjsProg replOpts--  -- link:-  unless forRepl $ do-    info verbosity "Linking..."-    runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }---- |Install for ghc, .hi, .a and, if --with-ghci given, .o-installLib    :: Verbosity-              -> LocalBuildInfo-              -> FilePath  -- ^install location-              -> FilePath  -- ^install location for dynamic libraries-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do-  whenVanilla $ copyModuleFiles "js_hi"-  whenProf    $ copyModuleFiles "js_p_hi"-  whenShared  $ copyModuleFiles "js_dyn_hi"--  whenVanilla $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) vanillaLibNames-  whenProf    $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) profileLibNames-  whenShared  $ mapM_ (installShared   builtDir dynlibTargetDir . toJSLibName) sharedLibNames--  when (ghcjsNativeToo $ compiler lbi) $ do-    -- copy .hi files over:-    whenVanilla $ copyModuleFiles "hi"-    whenProf    $ copyModuleFiles "p_hi"-    whenShared  $ copyModuleFiles "dyn_hi"--    -- copy the built library files over:-    whenVanilla $ mapM_ (installOrdinary builtDir targetDir)       vanillaLibNames-    whenProf    $ mapM_ (installOrdinary builtDir targetDir)       profileLibNames-    whenGHCi    $ mapM_ (installOrdinary builtDir targetDir)       ghciLibNames-    whenShared  $ mapM_ (installShared   builtDir dynlibTargetDir) sharedLibNames--  where-    install isShared srcDir dstDir name = do-      let src = srcDir </> name-          dst = dstDir </> name-      createDirectoryIfMissingVerbose verbosity True dstDir-      if isShared-        then do when (stripLibs lbi) $ Strip.stripLib verbosity-                                       (hostPlatform lbi) (withPrograms lbi) src-                installExecutableFile verbosity src dst-        else installOrdinaryFile   verbosity src dst--    installOrdinary = install False-    installShared   = install True--    copyModuleFiles ext =-      findModuleFiles [builtDir] [ext] (libModules lib)-      >>= installOrdinaryFiles verbosity targetDir--    cid = compilerId (compiler lbi)-    libNames = componentLibraries clbi-    vanillaLibNames = map mkLibName              libNames-    profileLibNames = map mkProfLibName          libNames-    ghciLibNames    = map Internal.mkGHCiLibName libNames-    sharedLibNames  = map (mkSharedLibName cid)  libNames--    hasLib    = not $ null (libModules lib)-                   && null (cSources (libBuildInfo lib))-    whenVanilla = when (hasLib && withVanillaLib lbi)-    whenProf    = when (hasLib && withProfLib    lbi)-    whenGHCi    = when (hasLib && withGHCiLib    lbi)-    whenShared  = when (hasLib && withSharedLib  lbi)--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-      fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix-      installBinary dest = do-        rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $-          [ "--install-executable"-          , buildPref </> exeName exe </> exeFileName-          , "-o", dest-          ] ++-          case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of-           (True, Just strip) -> ["-strip-program", programPath strip]-           _                  -> []-  installBinary (binDir </> fixedExeBaseName)--libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo-           -> Library -> ComponentLocalBuildInfo -> IO String-libAbiHash verbosity _pkg_descr lbi lib clbi = do-  let-      libBi       = libBuildInfo lib-      comp        = compiler lbi-      vanillaArgs =-        (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))-        `mappend` mempty {-          ghcOptMode         = toFlag GhcModeAbiHash,-          ghcOptPackageKey   = toFlag (pkgKey lbi),-          ghcOptInputModules = toNubListR $ exposedModules lib-        }-      profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {-                     ghcOptProfilingMode = toFlag True,-                     ghcOptExtra         = toNubListR (ghcjsProfOptions libBi)-                 }-      ghcArgs = if withVanillaLib lbi then vanillaArgs-           else if withProfLib    lbi then profArgs-           else error "libAbiHash: Can't find an enabled library way"-  ---  (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)-  getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs)--adjustExts :: String -> String -> GhcOptions -> GhcOptions-adjustExts hiSuf objSuf opts =-  opts `mappend` mempty {-    ghcOptHiSuffix  = toFlag hiSuf,-    ghcOptObjSuffix = toFlag objSuf-  }--registerPackage :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool-                -> PackageDBStack-                -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs-    (Right installedPkgInfo)--componentGhcOptions :: Verbosity -> LocalBuildInfo-                    -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                    -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-  let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir-  in  opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR-                             (hcOptions GHCJS bi)-           }--ghcjsProfOptions :: BuildInfo -> [String]-ghcjsProfOptions bi =-  hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi--ghcjsSharedOptions :: BuildInfo -> [String]-ghcjsSharedOptions bi =-  hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi--isDynamic :: Compiler -> Bool-isDynamic = Internal.ghcLookupProperty "GHC Dynamic"--supportsDynamicToo :: Compiler -> Bool-supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"--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 :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = ghcjsPkgProg-                                 , HcPkg.noPkgDbStack    = False-                                 , HcPkg.noVerboseFlag   = False-                                 , HcPkg.flagPackageConf = False-                                 , HcPkg.useSingleFileDb = v < [7,9]-                                 }-  where-    v                 = versionBranch ver-    Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf-    Just ver          = programVersion ghcjsPkgProg---- | 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 :: ProgramConfiguration -> FilePath-            -> (FilePath, FilePath, [String])-runCmd conf exe =-  ( script-  , programPath ghcjsProg-  , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]-  )-  where-    script = exe <.> "jsexe" </> "all" <.> "js"-    Just ghcjsProg = lookupProgram ghcjsProgram conf
− Distribution/Simple/Haddock.hs 
@@ -1,819 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Haddock--- Copyright   :  Isaac Jones 2003-2005--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module deals with the @haddock@ and @hscolour@ commands.--- It uses information about installed packages (from @ghc-pkg@) to find the--- locations of documentation for dependent packages, so it can create links.------ The @hscolour@ support allows generating HTML versions of the original--- source, with coloured syntax highlighting.--module Distribution.Simple.Haddock (-  haddock, hscolour,--  haddockPackagePaths-  ) where--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS---- local-import Distribution.Package-         ( PackageIdentifier(..)-         , Package(..)-         , PackageName(..), packageName )-import qualified Distribution.ModuleName as ModuleName-import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), usedExtensions-         , hcSharedOptions-         , Library(..), hasLibs, Executable(..)-         , TestSuite(..), TestSuiteInterface(..)-         , Benchmark(..), BenchmarkInterface(..) )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, CompilerFlavor(..)-         , compilerFlavor, compilerCompatVersion )-import Distribution.Simple.Program.GHC-         ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions )-import Distribution.Simple.Program-         ( ConfiguredProgram(..), lookupProgramVersion, requireProgramVersion-         , rawSystemProgram, rawSystemProgramStdout-         , hscolourProgram, haddockProgram )-import Distribution.Simple.PreProcess-         ( PPSuffixHandler, preprocessComponent)-import Distribution.Simple.Setup-         ( defaultHscolourFlags-         , Flag(..), toFlag, flagToMaybe, flagToList, 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(..), Component(..), ComponentLocalBuildInfo(..)-         , withAllComponentsInBuildOrder )-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, copyFileTo, warn, notice, intercalate, setupMessage-         , createDirectoryIfMissingVerbose-         , TempFileOptions(..), defaultTempFileOptions-         , withTempFileEx, copyFileVerbose-         , withTempDirectoryEx, matchFileGlob-         , findFileWithExtension, findFile )-import Distribution.Text-         ( display, simpleParse )-import Distribution.Utils.NubList-         ( toNubListR )--import Distribution.Verbosity-import Language.Haskell.Extension---import Control.Monad    ( when, forM_ )-import Data.Char        ( isSpace )-import Data.Either      ( rights )-import Data.Monoid-import Data.Foldable    ( foldl' )-import Data.Maybe       ( fromMaybe, listToMaybe )--import System.Directory (doesFileExist)-import System.FilePath  ( (</>), (<.>)-                        , normalise, splitPath, joinPath, isAbsolute )-import System.IO        (hClose, hPutStr, hPutStrLn, hSetEncoding, utf8)-import Distribution.Version---- --------------------------------------------------------------------------------- Types---- | A record that represents the arguments to the haddock executable, a product--- monoid.-data HaddockArgs = HaddockArgs {- argInterfaceFile :: Flag FilePath,- -- ^ Path to the interface file, relative to argOutputDir, required.- argPackageName :: Flag PackageIdentifier,- -- ^ Package name, required.- argHideModules :: (All,[ModuleName.ModuleName]),- -- ^ (Hide modules ?, modules to hide)- argIgnoreExports :: Any,- -- ^ Ignore export lists in modules?- argLinkSource :: Flag (Template,Template,Template),- -- ^ (Template for modules, template for symbols, template for lines).- argCssFile :: Flag FilePath,- -- ^ Optional custom CSS file.- argContents :: Flag String,- -- ^ Optional URL to contents page.- argVerbose :: Any,- argOutput :: Flag [Output],- -- ^ HTML or Hoogle doc or both? Required.- argInterfaces :: [(FilePath, Maybe String)],- -- ^ [(Interface file, URL to the HTML docs for links)].- argOutputDir :: Directory,- -- ^ Where to generate the documentation.- argTitle :: Flag String,- -- ^ Page title, required.- argPrologue :: Flag String,- -- ^ Prologue text, required.- argGhcOptions :: Flag (GhcOptions, Version),- -- ^ Additional flags to pass to GHC.- argGhcLibDir :: Flag FilePath,- -- ^ To find the correct GHC, required.- 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)-    && not (fromFlag $ haddockTestSuites  haddockFlags)-    && not (fromFlag $ haddockBenchmarks  haddockFlags) =-      warn (fromFlag $ haddockVerbosity haddockFlags) $-           "No documentation was generated as this package does not contain "-        ++ "a library. Perhaps you want to use the --executables, --tests or"-        ++ " --benchmarks flags."--haddock pkg_descr lbi suffixes flags = do-    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)-    (confHaddock, version, _) <--      requireProgramVersion verbosity haddockProgram-        (orLaterVersion (Version [2,0] [])) (withPrograms lbi)--    -- various sanity checks-    when ( flag haddockHoogle-           && version < Version [2,2] []) $-         die "haddock 2.0 and 2.1 do not support the --hoogle flag."--    haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock-                              ["--ghc-version"]-    case (simpleParse haddockGhcVersionStr, compilerCompatVersion GHC comp) of-      (Nothing, _) -> die "Could not get GHC version from Haddock"-      (_, Nothing) -> die "Could not get GHC version from compiler"-      (Just haddockGhcVersion, Just ghcVersion)-        | 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--    -- the tools match the requests, we can proceed--    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity--    when (flag haddockHscolour) $-      hscolour' (warn verbosity) pkg_descr lbi suffixes-      (defaultHscolourFlags `mappend` haddockToHscolour flags)--    libdirArgs <- getGhcLibDir  verbosity lbi-    let commonArgs = mconcat-            [ libdirArgs-            , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags-            , fromPackageDescription pkg_descr ]--    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do-      pre component-      let-        doExe com = case (compToExe com) of-          Just exe -> do-            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $-              \tmp -> do-                exeArgs <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate-                           version-                let exeArgs' = commonArgs `mappend` exeArgs-                runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'-          Nothing -> do-           warn (fromFlag $ haddockVerbosity flags)-             "Unsupported component, skipping..."-           return ()-      case component of-        CLib lib -> do-          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $-            \tmp -> do-              libArgs <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate-                         version-              let libArgs' = commonArgs `mappend` libArgs-              runHaddock verbosity tmpFileOpts comp confHaddock libArgs'-        CExe   _ -> when (flag haddockExecutables) $ doExe component-        CTest  _ -> when (flag haddockTestSuites)  $ doExe component-        CBench _ -> when (flag haddockBenchmarks)  $ doExe component--    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do-      files <- matchFileGlob fpath-      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)-  where-    verbosity     = flag haddockVerbosity-    keepTempFiles = flag haddockKeepTempFiles-    comp          = compiler lbi-    tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }-    flag f        = fromFlag $ f flags-    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation-                    $ flags---- --------------------------------------------------------------------------------- Contributions 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}"-                                         ,"src/%{MODULE/./-}.html#line-%{LINE}")-                               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--componentGhcOptions :: Verbosity -> LocalBuildInfo-                 -> BuildInfo -> ComponentLocalBuildInfo -> FilePath-                 -> GhcOptions-componentGhcOptions verbosity lbi bi clbi odir =-  let f = case compilerFlavor (compiler lbi) of-            GHC   -> GHC.componentGhcOptions-            GHCJS -> GHCJS.componentGhcOptions-            _     -> error $-                       "Distribution.Simple.Haddock.componentGhcOptions:" ++-                       "haddock only supports GHC and GHCJS"-  in f verbosity lbi bi clbi odir--fromLibrary :: Verbosity-            -> FilePath-            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo-            -> Maybe PathTemplate -- ^ template for HTML location-            -> Version-            -> IO HaddockArgs-fromLibrary verbosity tmp lbi lib clbi htmlTemplate haddockVersion = do-    inFiles <- map snd `fmap` getLibSourceFiles lbi lib-    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate-    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                          -- Noooooooooo!!!!!111-                          -- haddock stomps on our precious .hi-                          -- and .o files. Workaround by telling-                          -- haddock to write them elsewhere.-                          ghcOptObjDir     = toFlag tmp,-                          ghcOptHiDir      = toFlag tmp,-                          ghcOptStubDir    = toFlag tmp,-                          ghcOptPackageKey = toFlag $ pkgKey lbi-                      } `mappend` getGhcCppOpts haddockVersion bi-        sharedOpts = vanillaOpts {-                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                         ghcOptFPic        = toFlag True,-                         ghcOptHiSuffix    = toFlag "dyn_hi",-                         ghcOptObjSuffix   = toFlag "dyn_o",-                         ghcOptExtra       =-                           toNubListR $ hcSharedOptions GHC bi--                     }-    opts <- if withVanillaLib lbi-            then return vanillaOpts-            else if withSharedLib lbi-            then return sharedOpts-            else die $ "Must have vanilla or shared libraries "-                       ++ "enabled in order to run haddock"-    ghcVersion <- maybe (die "Compiler has no GHC version")-                        return-                        (compilerCompatVersion GHC (compiler lbi))--    return ifaceArgs {-      argHideModules = (mempty,otherModules $ bi),-      argGhcOptions  = toFlag (opts, ghcVersion),-      argTargets     = inFiles-    }-  where-    bi = libBuildInfo lib--fromExecutable :: Verbosity-               -> FilePath-               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo-               -> Maybe PathTemplate -- ^ template for HTML location-               -> Version-               -> IO HaddockArgs-fromExecutable verbosity tmp lbi exe clbi htmlTemplate haddockVersion = do-    inFiles <- map snd `fmap` getExeSourceFiles lbi exe-    ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate-    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                          -- Noooooooooo!!!!!111-                          -- haddock stomps on our precious .hi-                          -- and .o files. Workaround by telling-                          -- haddock to write them elsewhere.-                          ghcOptObjDir  = toFlag tmp,-                          ghcOptHiDir   = toFlag tmp,-                          ghcOptStubDir = toFlag tmp-                      } `mappend` getGhcCppOpts haddockVersion bi-        sharedOpts = vanillaOpts {-                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,-                         ghcOptFPic        = toFlag True,-                         ghcOptHiSuffix    = toFlag "dyn_hi",-                         ghcOptObjSuffix   = toFlag "dyn_o",-                         ghcOptExtra       =-                           toNubListR $ hcSharedOptions GHC bi-                     }-    opts <- if withVanillaLib lbi-            then return vanillaOpts-            else if withSharedLib lbi-            then return sharedOpts-            else die $ "Must have vanilla or shared libraries "-                       ++ "enabled in order to run haddock"-    ghcVersion <- maybe (die "Compiler has no GHC version")-                        return-                        (compilerCompatVersion GHC (compiler lbi))--    return ifaceArgs {-      argGhcOptions = toFlag (opts, ghcVersion),-      argOutputDir  = Dir (exeName exe),-      argTitle      = Flag (exeName exe),-      argTargets    = inFiles-    }-  where-    bi = buildInfo exe--compToExe :: Component -> Maybe Executable-compToExe comp =-  case comp of-    CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->-      Just Executable {-        exeName    = testName test,-        modulePath = f,-        buildInfo  = testBuildInfo test-      }-    CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->-      Just Executable {-        exeName    = benchmarkName bench,-        modulePath = f,-        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 lbi clbi htmlTemplate-    maybe (return ()) (warn verbosity) warnings-    return $ mempty {-                 argInterfaces = packageFlags-               }--getGhcCppOpts :: Version-              -> BuildInfo-              -> GhcOptions-getGhcCppOpts haddockVersion bi =-    mempty {-        ghcOptExtensions   = toNubListR [EnableExtension CPP | needsCpp],-        ghcOptCppOptions   = toNubListR defines-    }-  where-    needsCpp             = EnableExtension CPP `elem` usedExtensions bi-    defines              = [haddockVersionMacro]-    haddockVersionMacro  = "-D__HADDOCK_VERSION__="-                           ++ show (v1 * 1000 + v2 * 10 + v3)-      where-        [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]--getGhcLibDir :: Verbosity -> LocalBuildInfo-             -> IO HaddockArgs-getGhcLibDir verbosity lbi = do-    l <- case compilerFlavor (compiler lbi) of-            GHC   -> GHC.getLibDir   verbosity lbi-            GHCJS -> GHCJS.getLibDir verbosity lbi-            _     -> error "haddock only supports GHC and GHCJS"-    return $ mempty { argGhcLibDir = Flag l }---- --------------------------------------------------------------------------------- | Call haddock with the specified arguments.-runHaddock :: Verbosity-              -> TempFileOptions-              -> Compiler-              -> ConfiguredProgram-              -> HaddockArgs-              -> IO ()-runHaddock verbosity tmpFileOpts comp confHaddock args = do-  let haddockVersion = fromMaybe (error "unable to determine haddock version")-                       (programVersion confHaddock)-  renderArgs verbosity tmpFileOpts haddockVersion comp args $-    \(flags,result)-> do--      rawSystemProgram verbosity confHaddock flags--      notice verbosity $ "Documentation created: " ++ result---renderArgs :: Verbosity-              -> TempFileOptions-              -> Version-              -> Compiler-              -> HaddockArgs-              -> (([String], FilePath) -> IO a)-              -> IO a-renderArgs verbosity tmpFileOpts version comp args k = do-  let haddockSupportsUTF8          = version >= Version [2,14,4] []-      haddockSupportsResponseFiles = version >  Version [2,16,2] []-  createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $-    \prologueFileName h -> do-          do-             when haddockSupportsUTF8 (hSetEncoding h utf8)-             hPutStrLn h $ fromFlag $ argPrologue args-             hClose h-             let pflag = "--prologue=" ++ prologueFileName-                 renderedArgs = pflag : renderPureArgs version comp args-             if haddockSupportsResponseFiles -               then-                 withTempFileEx tmpFileOpts outputDir "haddock-response.txt" $-                    \responseFileName hf -> do-                         when haddockSupportsUTF8 (hSetEncoding hf utf8)-                         hPutStr hf $ unlines $ map escapeArg renderedArgs-                         hClose hf-                         let respFile = "@" ++ responseFileName-                         k ([respFile], result)-               else-                 k (renderedArgs, result)-    where-      outputDir = (unDir $ argOutputDir args)-      result = intercalate ", "-             . map (\o -> outputDir </>-                            case o of-                              Html -> "index.html"-                              Hoogle -> pkgstr <.> "txt")-             $ arg argOutput-            where-              pkgstr = display $ packageName pkgid-              pkgid = arg argPackageName-      arg f = fromFlag $ f args-      -- 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.-      escape cs c-        |    isSpace c-          || '\\' == c-          || '\'' == c-          || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result-        | otherwise    = c:cs-      escapeArg = reverse . foldl' escape []--renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]-renderPureArgs version comp args = concat-    [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)-      . fromFlag . argInterfaceFile $ args--    , if isVersion 2 16-        then (\pkg -> [ "--package-name=" ++ display (pkgName pkg)-                      , "--package-version="++display (pkgVersion pkg)-                      ])-             . fromFlag . argPackageName $ args-        else []--    , (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b)-                     . argHideModules $ args--    , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args--    , maybe [] (\(m,e,l) ->-                 ["--source-module=" ++ m-                 ,"--source-entity=" ++ e]-                 ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]-                    else []-               ) . flagToMaybe . argLinkSource $ args--    , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args--    , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args--    , bool [] [verbosityFlag] . getAny . argVerbose $ args--    , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")-      . fromFlag . argOutput $ args--    , renderInterfaces . argInterfaces $ args--    , (:[]) . ("--odir="++) . unDir . argOutputDir $ args--    , (:[]) . ("--title="++)-      . (bool (++" (internal documentation)")-         id (getAny $ argIgnoreExports args))-      . fromFlag . argTitle $ args--    , [ "--optghc=" ++ opt | (opts, _ghcVer) <- flagToList (argGhcOptions args)-                           , opt <- renderGhcOptions comp opts ]--    , maybe [] (\l -> ["-B"++l]) $-      flagToMaybe (argGhcLibDir args) -- error if Nothing?--    , argTargets $ args-    ]-    where-      renderInterfaces =-        map (\(i,mh) -> "--read-interface=" ++-          maybe "" (++",") mh ++ i)-      bool a b c = if c then a else b-      isVersion major minor  = version >= Version [major,minor]  []-      verbosityFlag-       | isVersion 2 5 = "--verbosity=1"-       | otherwise     = "--verbose"--------------------------------------------------------------------------------------- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and--- HTML paths, and an optional warning for packages with missing documentation.-haddockPackagePaths :: [InstalledPackageInfo]-                    -> Maybe (InstalledPackageInfo -> FilePath)-                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)-haddockPackagePaths ipkgs mkHtmlPath = do-  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 pkgid)-    | ipkg <- ipkgs, let pkgid = packageId ipkg-    , pkgName pkgid `notElem` noHaddockWhitelist-    ]--  let missing = [ pkgid | Left pkgid <- interfaces ]-      warning = "The documentation for the following packages are not "-             ++ "installed. No links will be generated to these packages: "-             ++ intercalate ", " (map display 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 PackageName [ "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 -> fmap fixFileUrl-                        (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))-        Just mkPath -> Just (mkPath pkg)-      return (interface, if null html then Nothing else Just html)-      where-        -- 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.-        fixFileUrl f | isAbsolute f = "file://" ++ f-                     | otherwise    = f--haddockPackageFlags :: LocalBuildInfo-                    -> ComponentLocalBuildInfo-                    -> Maybe PathTemplate-                    -> IO ([(FilePath, Maybe FilePath)], Maybe String)-haddockPackageFlags lbi clbi htmlTemplate = do-  let allPkgs = installedPkgs lbi-      directDeps = map fst (componentPackageDeps clbi)-  transitiveDeps <- case dependencyClosure allPkgs directDeps of-    Left x    -> return x-    Right inf -> die $ "internal error when calculating transitive "-                    ++ "package dependencies.\nDebug info: " ++ show inf-  haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath-    where-      mkHtmlPath                  = fmap expandTemplateVars htmlTemplate-      expandTemplateVars tmpl pkg =-        fromPathTemplate . substPathTemplate (env pkg) $ tmpl-      env pkg                     = haddockTemplateEnv lbi (packageId pkg)---haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv-haddockTemplateEnv lbi pkg_id =-  (PrefixVar, prefix (installDirTemplates lbi))-  : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerInfo (compiler lbi))-  (hostPlatform 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' die pkg_descr lbi suffixes flags- where-   verbosity  = fromFlag (hscolourVerbosity flags)-   distPref = fromFlag $ hscolourDistPref flags--hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.-          -> PackageDescription-          -> LocalBuildInfo-          -> [PPSuffixHandler]-          -> HscolourFlags-          -> IO ()-hscolour' onNoHsColour pkg_descr lbi suffixes flags =-    either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<-      lookupProgramVersion verbosity hscolourProgram-      (orLaterVersion (Version [1,8] [])) (withPrograms lbi)-  where-    go :: ConfiguredProgram -> IO ()-    go hscolourProg = do-      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-      withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do-        pre comp-        let-          doExe com = case (compToExe com) of-            Just exe -> do-              let outputDir = hscolourPref distPref pkg_descr-                              </> exeName exe </> "src"-              runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe-            Nothing -> do-              warn (fromFlag $ hscolourVerbosity flags)-                "Unsupported component, skipping..."-              return ()-        case comp of-          CLib lib -> do-            let outputDir = hscolourPref distPref pkg_descr </> "src"-            runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib-          CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp-          CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp-          CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp--    stylesheet = flagToMaybe (hscolourCSS flags)--    verbosity  = fromFlag (hscolourVerbosity flags)-    distPref   = fromFlag (hscolourDistPref flags)--    runHsColour prog outputDir moduleFiles = do-         createDirectoryIfMissingVerbose verbosity True outputDir--         case stylesheet of -- copy the CSS file-           Nothing | programVersion prog >= Just (Version [1,9] []) ->-                       rawSystemProgram verbosity prog-                          ["-print-css", "-o" ++ outputDir </> "hscolour.css"]-                   | otherwise -> return ()-           Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")--         forM_ 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,-      hscolourTestSuites  = haddockTestSuites  flags,-      hscolourBenchmarks  = haddockBenchmarks  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,-                argGhcOptions = 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,-                argGhcOptions = mult argGhcOptions,-                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/HaskellSuite.hs 
@@ -1,228 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Simple.HaskellSuite where--import Control.Monad-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-#endif-import Data.Maybe-import Data.Version-import qualified Data.Map as M (empty)--import Distribution.Simple.Program-import Distribution.Simple.Compiler as Compiler-import Distribution.Simple.Utils-import Distribution.Simple.BuildPaths-import Distribution.Verbosity-import Distribution.Text-import Distribution.Package-import Distribution.InstalledPackageInfo hiding (includeDirs)-import Distribution.Simple.PackageIndex as PackageIndex-import Distribution.PackageDescription-import Distribution.Simple.LocalBuildInfo-import Distribution.System (Platform)-import Distribution.Compat.Exception-import Language.Haskell.Extension-import Distribution.Simple.Program.Builtin-  (haskellSuiteProgram, haskellSuitePkgProgram)--configure-  :: Verbosity -> Maybe FilePath -> Maybe FilePath-  -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)-configure verbosity mbHcPath hcPkgPath conf0 = do--  -- We have no idea how a haskell-suite tool is named, so we require at-  -- least some information from the user.-  hcPath <--    let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)"-    in maybe (die msg) return mbHcPath--  when (isJust hcPkgPath) $-    warn verbosity "--with-hc-pkg option is ignored for haskell-suite"--  (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0--  -- Update our pkg tool. It uses the same executable as the compiler, but-  -- all command start with "pkg"-  (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1-  let conf2 =-        updateProgram-          confdPkg-            { programLocation = programLocation confdCompiler-            , programDefaultArgs = ["pkg"]-            }-          conf1--  return (comp, Nothing, conf2)--  where-    configureCompiler hcPath conf0' = do-      let-        haskellSuiteProgram' =-          haskellSuiteProgram-            { programFindLocation = \v _p -> findProgramLocation v hcPath }--      -- NB: cannot call requireProgram right away — it'd think that-      -- the program is already configured and won't reconfigure it again.-      -- Instead, call configureProgram directly first.-      conf1 <- configureProgram verbosity haskellSuiteProgram' conf0'-      (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1--      extensions <- getExtensions verbosity confdCompiler-      languages  <- getLanguages  verbosity confdCompiler-      (compName, compVersion) <--        getCompilerVersion verbosity confdCompiler--      let-        comp = Compiler {-          compilerId             = CompilerId (HaskellSuite compName) compVersion,-          compilerAbiTag         = Compiler.NoAbiTag,-          compilerCompat         = [],-          compilerLanguages      = languages,-          compilerExtensions     = extensions,-          compilerProperties     = M.empty-        }--      return (comp, confdCompiler, conf2)--hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)-hstoolVersion = findProgramVersion "--hspkg-version" id--numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)-numericVersion = findProgramVersion "--compiler-version" (last . words)--getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)-getCompilerVersion verbosity prog = do-  output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]-  let-    parts = words output-    name = concat $ init parts -- there shouldn't be any spaces in the name anyway-    versionStr = last parts-  version <--    maybe (die "haskell-suite: couldn't determine compiler version") return $-      simpleParse versionStr-  return (name, version)--getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)]-getExtensions verbosity prog = do-  extStrs <--    lines <$>-    rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]-  return-    [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ]--getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)]-getLanguages verbosity prog = do-  langStrs <--    lines <$>-    rawSystemStdout verbosity (programPath prog) ["--supported-languages"]-  return-    [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ]---- Other compilers do some kind of a packagedb stack check here. Not sure--- if we need something like that as well.-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration-                     -> IO InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf =-  liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb ->-    do str <--        getDbProgramOutput verbosity haskellSuitePkgProgram conf-                ["dump", packageDbOpt packagedb]-         `catchExit` \_ -> die $ "pkg dump failed"-       case parsePackages str of-         Right ok -> return ok-         _       -> die "failed to parse output of 'pkg dump'"--  where-    parsePackages str =-      let parsed = map parseInstalledPackageInfo (splitPkgs str)-       in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Right [ pkg | ParseOk _ pkg <- parsed ]-            msgs -> Left 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--buildLib-  :: Verbosity -> PackageDescription -> LocalBuildInfo-  -> Library -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  -- In future, there should be a mechanism for the compiler to request any-  -- number of the above parameters (or their parts) — in particular,-  -- pieces of PackageDescription.-  ---  -- For now, we only pass those that we know are used.--  let odir = buildDir lbi-      bi = libBuildInfo lib-      srcDirs = hsSourceDirs bi ++ [odir]-      dbStack = withPackageDB lbi-      language = fromMaybe Haskell98 (defaultLanguage bi)-      conf = withPrograms lbi-      pkgid = packageId pkg_descr--  runDbProgram verbosity haskellSuiteProgram conf $-    [ "compile", "--build-dir", odir ] ++-    concat [ ["-i", d] | d <- srcDirs ] ++-    concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] ++-    [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++-    [ "--package-name", display pkgid ] ++-    concat [ ["--package-id", display ipkgid ]-           | (ipkgid, _) <- componentPackageDeps clbi ] ++-    ["-G", display language] ++-    concat [ ["-X", display ex] | ex <- usedExtensions bi ] ++-    cppOptions (libBuildInfo lib) ++-    [ display modu | modu <- libModules lib ]----installLib-  :: Verbosity-  -> LocalBuildInfo-  -> FilePath  -- ^install location-  -> FilePath  -- ^install location for dynamic libraries-  -> FilePath  -- ^Build location-  -> PackageDescription-  -> Library-  -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do-  let conf = withPrograms lbi-  runDbProgram verbosity haskellSuitePkgProgram conf $-    [ "install-library"-    , "--build-dir", builtDir-    , "--target-dir", targetDir-    , "--dynlib-target-dir", dynlibTargetDir-    , "--package-id", display $ packageId pkg-    ] ++ map display (libModules lib)--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do-  (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi)--  runProgramInvocation verbosity $-    (programInvocation hspkg-      ["update", packageDbOpt $ last packageDbs])-      { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo }--initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()-initPackageDB verbosity conf dbPath =-  runDbProgram verbosity haskellSuitePkgProgram conf-    ["init", dbPath]--packageDbOpt :: PackageDB -> String-packageDbOpt GlobalPackageDB        = "--global"-packageDbOpt UserPackageDB          = "--user"-packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
− Distribution/Simple/Hpc.hs 
@@ -1,141 +0,0 @@--------------------------------------------------------------------------------- |--- 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-    , markupPackage-    , markupTest-    ) where--import Control.Monad ( when )-import Distribution.ModuleName ( main )-import Distribution.PackageDescription-    ( TestSuite(..)-    , testModules-    )-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Program-    ( hpcProgram-    , requireProgramVersion-    )-import Distribution.Simple.Program.Hpc ( markup, union )-import Distribution.Simple.Utils ( notice )-import Distribution.Version ( anyVersion )-import Distribution.Verbosity ( Verbosity() )-import System.Directory ( createDirectoryIfMissing, doesFileExist )-import System.FilePath---- ---------------------------------------------------------------------------- Haskell Program Coverage--data Way = Vanilla | Prof | Dyn-  deriving (Bounded, Enum, Eq, Read, Show)--hpcDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Directory containing component's HPC .mix files-hpcDir distPref way = distPref </> "hpc" </> wayDir-  where-    wayDir = case way of-      Vanilla -> "vanilla"-      Prof -> "prof"-      Dyn -> "dyn"--mixDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .mix files-mixDir distPref way name = hpcDir distPref way </> "mix" </> name--tixDir :: FilePath  -- ^ \"dist/\" prefix-       -> Way-       -> FilePath  -- ^ Component name-       -> FilePath  -- ^ Directory containing test suite's .tix files-tixDir distPref way name = hpcDir distPref way </> "tix" </> name---- | Path to the .tix file containing a test suite's sum statistics.-tixFilePath :: FilePath     -- ^ \"dist/\" prefix-            -> Way-            -> FilePath     -- ^ Component name-            -> FilePath     -- ^ Path to test suite's .tix file-tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"--htmlDir :: FilePath     -- ^ \"dist/\" prefix-        -> Way-        -> FilePath     -- ^ Component name-        -> FilePath     -- ^ Path to test suite's HTML markup directory-htmlDir distPref way name = hpcDir distPref way </> "html" </> name---- | 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---- | 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 way $ testName suite-    when tixFileExists $ do-        -- behaviour of 'markup' depends on version, so we need *a* version-        -- but no particular one-        (hpc, hpcVer, _) <- requireProgramVersion verbosity-            hpcProgram anyVersion (withPrograms lbi)-        let htmlDir_ = htmlDir distPref way $ testName suite-        markup hpc hpcVer verbosity-            (tixFilePath distPref way $ testName suite) mixDirs-            htmlDir_-            (testModules suite ++ [ main ])-        notice verbosity $ "Test coverage report written to "-                            ++ htmlDir_ </> "hpc_index" <.> "html"-  where-    way = guessWay lbi-    mixDirs = map (mixDir distPref way) [ testName suite, libName ]---- | 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 way . testName) suites-    tixFilesExist <- mapM doesFileExist tixFiles-    when (and tixFilesExist) $ do-        -- behaviour of 'markup' depends on version, so we need *a* version-        -- but no particular one-        (hpc, hpcVer, _) <- requireProgramVersion verbosity-            hpcProgram anyVersion (withPrograms lbi)-        let outFile = tixFilePath distPref way libName-            htmlDir' = htmlDir distPref way libName-            excluded = concatMap testModules suites ++ [ main ]-        createDirectoryIfMissing True $ takeDirectory outFile-        union hpc verbosity tixFiles outFile excluded-        markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded-        notice verbosity $ "Package coverage report written to "-                           ++ htmlDir' </> "hpc_index.html"-  where-    way = guessWay lbi-    mixDirs = map (mixDir distPref way) $ libName : map testName suites
− Distribution/Simple/Install.hs 
@@ -1,190 +0,0 @@--------------------------------------------------------------------------------- |--- 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,-  ) where--import Distribution.PackageDescription (-        PackageDescription(..), BuildInfo(..), Library(..),-        hasLibs, withLib, hasExes, withExe )-import Distribution.Package (Package(..))-import Distribution.Simple.LocalBuildInfo (-        LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,-        substPathTemplate, withLibLBI)-import Distribution.Simple.BuildPaths (haddockName, haddockPref)-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose-         , installDirectoryContents, installOrdinaryFile, isInSearchPath-         , die, info, notice, warn, matchDirFileGlob )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor )-import Distribution.Simple.Setup (CopyFlags(..), fromFlag)--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.JHC   as JHC-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite--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.--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,-         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 lfiles = licenseFiles pkg_descr-  unless (null lfiles) $ do-    createDirectoryIfMissingVerbose verbosity True docPref-    sequence_-      [ installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)-      | lfile <- lfiles ]--  let buildPref = buildDir lbi-  when (hasLibs pkg_descr) $-    notice verbosity ("Installing library in " ++ libPref)-  when (hasExes pkg_descr) $ do-    notice verbosity ("Installing executable(s) in " ++ binPref)-    inPath <- isInSearchPath binPref-    when (not inPath) $-      warn verbosity ("The directory " ++ binPref-                      ++ " is not in the system search path.")--  -- 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 withLibLBI pkg_descr lbi $-                  GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     GHCJS-> do withLibLBI pkg_descr lbi $-                  GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-                withExe pkg_descr $-                  GHCJS.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     LHC  -> do withLibLBI pkg_descr lbi $-                  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-     UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-     HaskellSuite {} ->-       withLib pkg_descr $-         HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr-     _    -> die $ "installing with "-                ++ display (compilerFlavor (compiler lbi))-                ++ " is not implemented"-  -- 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,608 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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,-        combineInstallDirs,-        absoluteInstallDirs,-        CopyDest(..),-        prefixRelativeInstallDirs,-        substituteInstallDirTemplates,--        PathTemplate,-        PathTemplateVariable(..),-        PathTemplateEnv,-        toPathTemplate,-        fromPathTemplate,-        substPathTemplate,-        initialPathTemplateEnv,-        platformTemplateEnv,-        compilerTemplateEnv,-        packageTemplateEnv,-        abiTemplateEnv,-        installDirsTemplateEnv,-  ) where---import Distribution.Compat.Binary (Binary)-import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe)-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif-import GHC.Generics (Generic)-import System.Directory (getAppUserDataDirectory)-import System.FilePath ((</>), isPathSeparator, pathSeparator)-import System.FilePath (dropDrive)--import Distribution.Package-         ( PackageIdentifier, PackageKey, packageName, packageVersion, packageKeyLibraryName )-import Distribution.System-         ( OS(..), buildOS, Platform(..) )-import Distribution.Compiler-         ( AbiTag(..), abiTagString, CompilerInfo(..), CompilerFlavor(..) )-import Distribution.Text-         ( display )--#if mingw32_HOST_OS-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,-        libexecdir   :: dir,-        includedir   :: dir,-        datadir      :: dir,-        datasubdir   :: dir,-        docdir       :: dir,-        mandir       :: dir,-        htmldir      :: dir,-        haddockdir   :: dir,-        sysconfdir   :: dir-    } deriving (Generic, Read, Show)--instance Binary dir => Binary (InstallDirs dir)--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),-    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),-    sysconfdir   = f (sysconfdir dirs)-  }--instance Monoid dir => Monoid (InstallDirs dir) where-  mempty = InstallDirs {-      prefix       = mempty,-      bindir       = mempty,-      libdir       = mempty,-      libsubdir    = mempty,-      dynlibdir    = mempty,-      libexecdir   = mempty,-      includedir   = mempty,-      datadir      = mempty,-      datasubdir   = mempty,-      docdir       = mempty,-      mandir       = mempty,-      htmldir      = mempty,-      haddockdir   = mempty,-      sysconfdir   = 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,-    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,-    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 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 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-           JHC    -> "$compiler"-           LHC    -> "$compiler"-           UHC    -> "$pkgid"-           _other -> "$abi" </> "$libname",-      dynlibdir    = "$libdir",-      libexecdir   = case buildOS of-        Windows   -> "$prefix" </> "$libname"-        _other    -> "$prefix" </> "libexec",-      includedir   = "$libdir" </> "$libsubdir" </> "include",-      datadir      = case buildOS of-        Windows   -> "$prefix"-        _other    -> "$prefix" </> "share",-      datasubdir   = "$abi" </> "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$abi" </> "$pkgid",-      mandir       = "$datadir" </> "man",-      htmldir      = "$docdir"  </> "html",-      haddockdir   = "$htmldir",-      sysconfdir   = "$prefix" </> "etc"-  }---- ------------------------------------------------------------------------------ Converting directories, absolute or prefix-relative---- | 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,-      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-                    -> PackageKey-                    -> CompilerInfo-                    -> CopyDest-                    -> Platform-                    -> InstallDirs PathTemplate-                    -> InstallDirs FilePath-absoluteInstallDirs pkgId pkg_key compilerId copydest platform dirs =-    (case copydest of-       CopyTo destdir -> fmap ((destdir </>) . dropDrive)-       _              -> id)-  . appendSubdirs (</>)-  . fmap fromPathTemplate-  $ substituteInstallDirTemplates env dirs-  where-    env = initialPathTemplateEnv pkgId pkg_key compilerId platform----- |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-                          -> PackageKey-                          -> CompilerInfo-                          -> Platform-                          -> InstallDirTemplates-                          -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkgId pkg_key compilerId platform 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 pkg_key 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, Generic, Ord)--instance Binary PathTemplate--data PathComponent =-       Ordinary FilePath-     | Variable PathTemplateVariable-     deriving (Eq, Ord, Generic)--instance Binary PathComponent--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@-     | PkgKeyVar     -- ^ The @$pkgkey@ package key path variable-     | LibNameVar    -- ^ The @$libname@ expanded package key path variable-     | CompilerVar   -- ^ The compiler name and version, eg @ghc-6.6.1@-     | OSVar         -- ^ The operating system name, eg @windows@ or @linux@-     | ArchVar       -- ^ The CPU architecture name, eg @i386@ or @x86_64@-     | AbiVar        -- ^ The Compiler's ABI identifier, $arch-$os-$compiler-$abitag-     | AbiTagVar     -- ^ The optional ABI tag for the compiler-     | ExecutableNameVar -- ^ The executable name; used in shell wrappers-     | TestSuiteNameVar   -- ^ The name of the test suite being run-     | TestSuiteResultVar -- ^ The result of the test suite being run, eg-                          -- @pass@, @fail@, or @error@.-     | BenchmarkNameVar   -- ^ The name of the benchmark being run-  deriving (Eq, Ord, Generic)--instance Binary PathTemplateVariable--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-                       -> PackageKey-                       -> CompilerInfo-                       -> Platform-                       -> PathTemplateEnv-initialPathTemplateEnv pkgId pkg_key compiler platform =-     packageTemplateEnv  pkgId pkg_key-  ++ compilerTemplateEnv compiler-  ++ platformTemplateEnv platform-  ++ abiTemplateEnv compiler platform--packageTemplateEnv :: PackageIdentifier -> PackageKey -> PathTemplateEnv-packageTemplateEnv pkgId pkg_key =-  [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])-  ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])-  ,(PkgKeyVar,   PathTemplate [Ordinary $ display pkg_key])-  ,(LibNameVar,  PathTemplate [Ordinary $ packageKeyLibraryName pkgId pkg_key])-  ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])-  ]--compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv-compilerTemplateEnv compiler =-  [(CompilerVar, PathTemplate [Ordinary $ display (compilerInfoId compiler)])-  ]--platformTemplateEnv :: Platform -> PathTemplateEnv-platformTemplateEnv (Platform arch os) =-  [(OSVar,       PathTemplate [Ordinary $ display os])-  ,(ArchVar,     PathTemplate [Ordinary $ display arch])-  ]--abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv-abiTemplateEnv compiler (Platform arch os) =-  [(AbiVar,      PathTemplate [Ordinary $ display arch ++ '-':display os ++-                                          '-':display (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)-  ,(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 PkgKeyVar     = "pkgkey"-  show LibNameVar     = "libname"-  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 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 ]-    -- NB: order matters! Longer strings first-    where vars = [("prefix",     PrefixVar)-                 ,("bindir",     BindirVar)-                 ,("libdir",     LibdirVar)-                 ,("libsubdir",  LibsubdirVar)-                 ,("datadir",    DatadirVar)-                 ,("datasubdir", DatasubdirVar)-                 ,("docdir",     DocdirVar)-                 ,("htmldir",    HtmldirVar)-                 ,("pkgid",      PkgIdVar)-                 ,("pkgkey",     PkgKeyVar)-                 ,("libname",    LibNameVar)-                 ,("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' ]--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-  m <- shGetFolderPath csidl_PROGRAM_FILES-#else-  let m = Nothing-#endif-  return (fromMaybe "C:\\Program Files" m)--#if 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--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"-            c_SHGetFolderPath :: Ptr ()-                              -> CInt-                              -> Ptr ()-                              -> CInt-                              -> CWString-                              -> IO CInt-#endif
− Distribution/Simple/JHC.hs 
@@ -1,196 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.JHC--- Copyright   :  Isaac Jones 2003-2006--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This module contains most of the JHC-specific code for configuring, building--- and installing packages.--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 (InstalledPackageIndex)-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(..), AbiTag(..)-         , 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 Distribution.System ( Platform )--import Data.List                ( nub )-import Data.Char                ( isSpace )-import qualified Data.Map as M  ( empty )-import Data.Maybe               ( fromMaybe )--import qualified Data.ByteString.Lazy.Char8 as BS.Char8----- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, 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,-        compilerAbiTag         = NoAbiTag,-        compilerCompat         = [],-        compilerLanguages      = jhcLanguages,-        compilerExtensions     = jhcLanguageExtensions,-        compilerProperties     = M.empty-      }-      compPlatform = Nothing-  return (comp, compPlatform, 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 InstalledPackageIndex-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 . BS.Char8.pack $ 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,803 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.LHC--- 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.LHC (-        configure, getInstalledPackages,-        buildLib, buildExe,-        installLib, installExe,-        registerPackage,-        hcPkgInfo,-        ghcOptions,-        ghcVerbosityOptions- ) where--import Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, hcProfOptions, hcSharedOptions-         , 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(..),-           LibraryName(..) )-import Distribution.Simple.InstallDirs-import Distribution.Simple.BuildPaths-import Distribution.Simple.Utils-import Distribution.Package-         ( Package(..) )-import qualified Distribution.ModuleName as ModuleName-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration-         , ProgramSearchPath, ProgramLocation(..)-         , rawSystemProgram, rawSystemProgramConf-         , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , requireProgramVersion-         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , arProgram, ldProgram-         , gccProgram, stripProgram-         , lhcProgram, lhcPkgProgram )-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Compiler-         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion-         , OptimisationLevel(..), PackageDB(..), PackageDBStack, AbiTag(..)-         , 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 qualified Data.Map as M  ( empty )-import Data.Maybe               ( catMaybes )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid              ( Monoid(..) )-#endif-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)-import Distribution.System ( Platform )---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, 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,-        compilerAbiTag         = NoAbiTag,-        compilerCompat         = [],-        compilerLanguages      = languages,-        compilerExtensions     = extensions,-        compilerProperties     = M.empty-      }-      conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld-      compPlatform = Nothing-  return (comp, compPlatform, 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 -> ProgramSearchPath -> IO (Maybe FilePath)-    findProg prog location | isWindows = \verbosity searchpath -> 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 searchpath-      | otherwise = programFindLocation prog--    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    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 gccProg {-                                programDefaultArgs = ["-B" ++ libDir,-                                                      "-I" ++ includeDir]-                              }-          UserSpecified {} -> return gccProg-      | otherwise = \_ gccProg -> return gccProg--    -- we need to find out if ld supports the -x flag-    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-    configureLd verbosity ldProg = do-      tempDir <- getTemporaryDirectory-      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->-             withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() { return 0; }"-               hClose testchnd; hClose testohnd-               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 ldProg { programDefaultArgs = ["-x"] }-        else return ldProg--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 InstalledPackageIndex-getInstalledPackages verbosity packagedbs conf = do-  checkPackageDbStack packagedbs-  pkgss <- getInstalledPackages' lhcPkg 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-    Just lhcPkg  = lookupProgram lhcPkgProgram 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' :: ConfiguredProgram -> Verbosity-                      -> [PackageDB] -> ProgramConfiguration-                      -> IO [(PackageDB, [InstalledPackageInfo])]-getInstalledPackages' lhcPkg 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) = "--" ++ packageDbFlag ++ "=" ++ path--    packageDbFlag-      | programVersion lhcPkg < Just (Version [7,5] [])-      = "package-conf"-      | otherwise-      = "package-db"---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-  libName <- case componentLibraries clbi of-             [libName] -> return libName-             [] -> die "No library name found when building library"-             _  -> die "Multiple library names found when building library"--  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 recursive 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"-             ]-          ++ hcProfOptions GHC libBi-      ghcArgsShared = ghcArgs-          ++ ["-dynamic",-              "-hisuf", "dyn_hi",-              "-osuf", "dyn_o", "-fPIC"-             ]-          ++ hcSharedOptions GHC 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)-      cid = compilerId (compiler lbi)-      vanillaLibFilePath = libTargetDir </> mkLibName           libName-      profileLibFilePath = libTargetDir </> mkProfLibName       libName-      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName--  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"-                     ] ++ hcProfOptions GHC 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 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 :: LocalBuildInfo -> [String]-ghcPackageDbOptions lbi = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-  (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)-                                       : concatMap specific dbs-  _                                   -> ierror- where-    specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ]-    specific _ = ierror-    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)--    dbstack = withPackageDB lbi-    packageDbFlag-      | compilerVersion (compiler lbi) < Version [7,5] []-      = "package-conf"-      | otherwise-      = "package-db"--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 lbi-     ++ ghcPackageFlags lbi clbi-     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]-     ++ (case withOptimization lbi of-           NoOptimisation -> []-           _              -> ["-optc-O2"])-     ++ ["-odir", odir]--mkGHCiLibName :: LibraryName -> String-mkGHCiLibName (LibraryName lib) = 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 libraries-              -> FilePath  -- ^Build location-              -> PackageDescription-              -> Library-              -> ComponentLocalBuildInfo-              -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = 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 $ mapM_ (copy builtDir targetDir)       vanillaLibNames-  ifProf    $ mapM_ (copy builtDir targetDir)       profileLibNames-  ifGHCi    $ mapM_ (copy builtDir targetDir)       ghciLibNames-  ifShared  $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames--  where-    cid = compilerId (compiler lbi)-    libNames = componentLibraries clbi-    vanillaLibNames = map mkLibName             libNames-    profileLibNames = map mkProfLibName         libNames-    ghciLibNames    = map mkGHCiLibName         libNames-    sharedLibNames  = map (mkSharedLibName cid) libNames--    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)---- -------------------------------------------------------------------------------- Registering--registerPackage-  :: Verbosity-  -> InstalledPackageInfo-  -> PackageDescription-  -> LocalBuildInfo-  -> Bool-  -> PackageDBStack-  -> IO ()-registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs =-  HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs-    (Right installedPkgInfo)--hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo-hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram    = lhcPkgProg-                                 , HcPkg.noPkgDbStack    = False-                                 , HcPkg.noVerboseFlag   = False-                                 , HcPkg.flagPackageConf = False-                                 , HcPkg.useSingleFileDb = True-                                 }-  where-    Just lhcPkgProg = lookupProgram lhcPkgProgram conf
− Distribution/Simple/LocalBuildInfo.hs 
@@ -1,504 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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(..),-        externalPackageDeps,-        inplacePackageId,--        -- * Buildable package components-        Component(..),-        ComponentName(..),-        showComponentName,-        ComponentLocalBuildInfo(..),-        LibraryName(..),-        foldComponent,-        componentName,-        componentBuildInfo,-        componentEnabled,-        componentDisabledReason,-        ComponentDisabledReason(..),-        pkgComponents,-        pkgEnabledComponents,-        lookupComponent,-        getComponent,-        getComponentLocalBuildInfo,-        allComponentsInBuildOrder,-        componentsInBuildOrder,-        checkComponentsCyclic,-        depLibraryPaths,--        withAllComponentsInBuildOrder,-        withComponentsInBuildOrder,-        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.InstalledPackageInfo (InstalledPackageInfo)-import Distribution.PackageDescription-         ( PackageDescription(..), withLib, Library(libBuildInfo), withExe-         , Executable(exeName, buildInfo), withTest, TestSuite(..)-         , BuildInfo(buildable), Benchmark(..), ModuleRenaming(..) )-import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Package-         ( PackageId, Package(..), InstalledPackageId(..), PackageKey-         , PackageName )-import Distribution.Simple.Compiler-         ( Compiler, compilerInfo, PackageDBStack, DebugInfoLevel-         , OptimisationLevel )-import Distribution.Simple.PackageIndex-         ( InstalledPackageIndex, allPackages )-import Distribution.ModuleName ( ModuleName )-import Distribution.Simple.Setup-         ( ConfigFlags )-import Distribution.Simple.Utils-         ( shortRelativePath )-import Distribution.Text-         ( display )-import Distribution.System-         ( Platform (..) )--import Data.Array ((!))-import Distribution.Compat.Binary (Binary)-import Data.Graph-import Data.List (nub, find, stripPrefix)-import Data.Maybe-import Data.Tree  (flatten)-import GHC.Generics (Generic)-import Data.Map (Map)--import System.Directory (doesDirectoryExist, canonicalizePath)---- | 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 different-                -- kinds of files-        --TODO: inplaceDirTemplates :: InstallDirs FilePath-        compiler      :: Compiler,-                -- ^ The compiler we're building with-        hostPlatform  :: Platform,-                -- ^ The platform we're building for-        buildDir      :: FilePath,-                -- ^ Where to build the package.-        componentsConfigs   :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],-                -- ^ All the components to build, ordered by topological sort, and with their dependencies-                -- over the intrapackage dependency graph-        installedPkgs :: InstalledPackageIndex,-                -- ^ 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.-        pkgKey        :: PackageKey,-                -- ^ The package key for the current build, calculated from-                -- the package ID and the dependency graph.-        instantiatedWith :: [(ModuleName, (InstalledPackageInfo, ModuleName))],-        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).-        withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (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-        stripLibs     :: Bool,  -- ^Whether to strip libraries during install-        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables-        progSuffix    :: PathTemplate, -- ^Suffix to be appended to installed executables-        relocatable   :: Bool --  ^Whether to build a relocatable package-  } deriving (Generic, Read, Show)--instance Binary LocalBuildInfo---- | 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 =-    -- TODO:  what about non-buildable components?-    nub [ (ipkgid, pkgid)-        | (_,clbi,_)      <- componentsConfigs lbi-        , (ipkgid, pkgid) <- componentPackageDeps clbi-        , not (internal pkgid) ]-  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 (Eq, Generic, Ord, Read, Show)--instance Binary ComponentName--showComponentName :: ComponentName -> String-showComponentName CLibName          = "library"-showComponentName (CExeName   name) = "executable '" ++ name ++ "'"-showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"-showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"--data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    -- | 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)],-    componentExposedModules :: [Installed.ExposedModule],-    componentPackageRenaming :: Map PackageName ModuleRenaming,-    componentLibraries :: [LibraryName]-  }-  | ExeComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  | TestComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  | BenchComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentPackageRenaming :: Map PackageName ModuleRenaming-  }-  deriving (Generic, Read, Show)--instance Binary ComponentLocalBuildInfo--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--data LibraryName = LibraryName String-    deriving (Generic, Read, Show)--instance Binary LibraryName--componentBuildInfo :: Component -> BuildInfo-componentBuildInfo =-  foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo--componentName :: Component -> ComponentName-componentName =-  foldComponent (const CLibName)-                (CExeName . exeName)-                (CTestName . testName)-                (CBenchName . benchmarkName)---- | All the components in the package (libs, exes, or test suites).----pkgComponents :: PackageDescription -> [Component]-pkgComponents pkg =-    [ CLib  lib | Just lib <- [library pkg] ]- ++ [ CExe  exe | exe <- executables pkg ]- ++ [ CTest tst | tst <- testSuites  pkg ]- ++ [ CBench bm | bm  <- benchmarks  pkg ]---- | All the components in the package that are buildable and enabled.--- Thus this excludes non-buildable components and test suites or benchmarks--- that have been disabled.----pkgEnabledComponents :: PackageDescription -> [Component]-pkgEnabledComponents = filter componentEnabled . pkgComponents--componentEnabled :: Component -> Bool-componentEnabled = isNothing . componentDisabledReason--data ComponentDisabledReason = DisabledComponent-                             | DisabledAllTests-                             | DisabledAllBenchmarks--componentDisabledReason :: Component -> Maybe ComponentDisabledReason-componentDisabledReason (CLib  lib)-  | not (buildable (libBuildInfo lib))      = Just DisabledComponent-componentDisabledReason (CExe  exe)-  | not (buildable (buildInfo exe))         = Just DisabledComponent-componentDisabledReason (CTest tst)-  | not (buildable (testBuildInfo tst))     = Just DisabledComponent-  | not (testEnabled tst)                   = Just DisabledAllTests-componentDisabledReason (CBench bm)-  | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent-  | not (benchmarkEnabled bm)               = Just DisabledAllBenchmarks-componentDisabledReason _                   = Nothing--lookupComponent :: PackageDescription -> ComponentName -> Maybe Component-lookupComponent pkg CLibName =-    fmap CLib $ library pkg-lookupComponent pkg (CExeName name) =-    fmap CExe $ find ((name ==) . exeName) (executables pkg)-lookupComponent pkg (CTestName name) =-    fmap CTest $ find ((name ==) . testName) (testSuites pkg)-lookupComponent pkg (CBenchName name) =-    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)--getComponent :: PackageDescription -> ComponentName -> Component-getComponent pkg cname =-    case lookupComponent pkg cname of-      Just cpnt -> cpnt-      Nothing   -> missingComponent-  where-    missingComponent =-      error $ "internal error: the package description contains no "-           ++ "component corresponding to " ++ show cname---getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo-getComponentLocalBuildInfo lbi cname =-    case [ clbi-         | (cname', clbi, _) <- componentsConfigs lbi-         , cname == cname' ] of-      [clbi] -> clbi-      _      -> missingComponent-  where-    missingComponent =-      error $ "internal error: there is no configuration data "-           ++ "for component " ++ show cname----- |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 ->-      f lib (getComponentLocalBuildInfo lbi CLibName)---- | 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 ->-      f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe)))--withTestLBI :: PackageDescription -> LocalBuildInfo-            -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withTestLBI pkg_descr lbi f =-    withTest pkg_descr $ \test ->-      f test (getComponentLocalBuildInfo lbi (CTestName (testName test)))--{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-}-withComponentsLBI :: PackageDescription -> LocalBuildInfo-                  -> (Component -> ComponentLocalBuildInfo -> IO ())-                  -> IO ()-withComponentsLBI = withAllComponentsInBuildOrder---- | 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 =-    sequence_-      [ f (getComponent pkg cname) clbi-      | (cname, clbi) <- allComponentsInBuildOrder lbi ]--withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo-                                  -> [ComponentName]-                                  -> (Component -> ComponentLocalBuildInfo -> IO ())-                                  -> IO ()-withComponentsInBuildOrder pkg lbi cnames f =-    sequence_-      [ f (getComponent pkg cname') clbi-      | (cname', clbi) <- componentsInBuildOrder lbi cnames ]--allComponentsInBuildOrder :: LocalBuildInfo-                          -> [(ComponentName, ComponentLocalBuildInfo)]-allComponentsInBuildOrder lbi =-    componentsInBuildOrder lbi-      [ cname | (cname, _, _) <- componentsConfigs lbi ]--componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]-                       -> [(ComponentName, ComponentLocalBuildInfo)]-componentsInBuildOrder lbi cnames =-      map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode)-    . postOrder graph-    . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname))-    $ cnames-  where-    (graph, vertexToNode, keyToVertex) =-      graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi))--    noSuchComp cname = error $ "internal error: componentsInBuildOrder: "-                            ++ "no such component: " ++ show cname--    postOrder :: Graph -> [Vertex] -> [Vertex]-    postOrder g vs = postorderF (dfs g vs) []--    postorderF   :: Forest a -> [a] -> [a]-    postorderF ts = foldr (.) id $ map postorderT ts--    postorderT :: Tree a -> [a] -> [a]-    postorderT (Node a ts) = postorderF ts . (a :)--checkComponentsCyclic :: Ord key => [(node, key, [key])]-                      -> Maybe [(node, key, [key])]-checkComponentsCyclic es =-    let (graph, vertexToNode, _) = graphFromEdges es-        cycles                   = [ flatten c | c <- scc graph, isCycle c ]-        isCycle (Node v [])      = selfCyclic v-        isCycle _                = True-        selfCyclic v             = v `elem` graph ! v-     in case cycles of-         []    -> Nothing-         (c:_) -> Just (map vertexToNode c)---- | 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 clbi = do-    let pkgDescr    = localPkgDescr lbi-        installDirs = absoluteInstallDirs pkgDescr lbi NoCopyDest-        executable  = case clbi of-                        ExeComponentLocalBuildInfo {} -> True-                        _                             -> False-        relDir | executable = bindir installDirs-               | otherwise  = libdir installDirs--    let hasInternalDeps = not $ null-                        $ [ pkgid-                          | (_,pkgid) <- componentPackageDeps clbi-                          , internal pkgid-                          ]--    let ipkgs          = allPackages (installedPkgs lbi)-        allDepLibDirs  = concatMap Installed.libraryDirs ipkgs-        internalLib-          | inplace    = buildDir lbi-          | otherwise  = libdir installDirs-        allDepLibDirs' = if hasInternalDeps-                            then internalLib : allDepLibDirs-                            else allDepLibDirs-    allDepLibDirsC <- mapM canonicalizePathNoFail allDepLibDirs'--    let p                = prefix installDirs-        prefixRelative l = isJust (stripPrefix p l)-        libPaths-          | relative &&-            prefixRelative relDir = map (\l ->-                                          if prefixRelative l-                                             then shortRelativePath relDir l-                                             else l-                                        ) allDepLibDirsC-          | otherwise             = allDepLibDirsC--    return libPaths-  where-    internal pkgid = pkgid == packageId (localPkgDescr lbi)-    -- 'canonicalizePath' fails on UNIX when the directory does not exists.-    -- So just don't canonicalize when it doesn't exist.-    canonicalizePathNoFail p = do-      exists <- doesDirectoryExist p-      if exists-         then canonicalizePath p-         else return p----- -------------------------------------------------------------------------------- Wrappers for a couple functions from InstallDirs---- |See 'InstallDirs.absoluteInstallDirs'-absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest-                    -> InstallDirs FilePath-absoluteInstallDirs pkg lbi copydest =-  InstallDirs.absoluteInstallDirs-    (packageId pkg)-    (pkgKey lbi)-    (compilerInfo (compiler lbi))-    copydest-    (hostPlatform lbi)-    (installDirTemplates lbi)---- |See 'InstallDirs.prefixRelativeInstallDirs'-prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo-                          -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkg_descr lbi =-  InstallDirs.prefixRelativeInstallDirs-    (packageId pkg_descr)-    (pkgKey lbi)-    (compilerInfo (compiler lbi))-    (hostPlatform lbi)-    (installDirTemplates lbi)--substPathTemplate :: PackageId -> LocalBuildInfo-                  -> PathTemplate -> FilePath-substPathTemplate pkgid lbi = fromPathTemplate-                                . ( InstallDirs.substPathTemplate env )-    where env = initialPathTemplateEnv-                   pkgid-                   (pkgKey lbi)-                   (compilerInfo (compiler lbi))-                   (hostPlatform lbi)
− Distribution/Simple/PackageIndex.hs 
@@ -1,695 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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-  InstalledPackageIndex,-  PackageIndex,-  FakeMap,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,--  insert,--  deleteInstalledPackageId,-  deleteSourcePackageId,-  deletePackageName,---  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  lookupInstalledPackageId,-  lookupSourcePackageId,-  lookupPackageId,-  lookupPackageName,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,-  allPackagesBySourcePackageId,--  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,-  moduleNameIndex,--  -- ** Variants of special queries supporting fake map-  fakeLookupInstalledPackageId,-  brokenPackages',-  dependencyClosure',-  reverseDependencyClosure',-  dependencyInconsistencies',-  dependencyCycles',-  dependencyGraph',-  ) where--import Control.Exception (assert)-import Data.Array ((!))-import qualified Data.Array as Array-import Distribution.Compat.Binary (Binary)-import qualified Data.Graph as Graph-import Data.List as List-         ( null, foldl', sort-         , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid (Monoid(..))-#endif-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (isNothing, fromMaybe)-import qualified Data.Tree  as Tree-import GHC.Generics (Generic)-import Prelude hiding (lookup)--import Distribution.Package-         ( PackageName(..), PackageId-         , Package(..), packageName, packageVersion-         , Dependency(Dependency)--, --PackageFixedDeps(..)-         , InstalledPackageId(..), PackageInstalled(..) )-import Distribution.ModuleName-         ( ModuleName )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import qualified Distribution.InstalledPackageInfo as IPI-import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, comparing, equating)---- Note [FakeMap]--------------------- We'd like to use the PackageIndex defined in this module for--- cabal-install's InstallPlan.  However, at the moment, this--- data structure is indexed by InstalledPackageId, which we don't--- know until after we've compiled a package (whereas InstallPlan--- needs to store not-compiled packages in the index.) Eventually,--- an InstalledPackageId will be calculatable prior to actually--- building the package (making it something of a misnomer), but--- at the moment, the "fake installed package ID map" is a workaround--- to solve this problem while reusing PackageIndex.  The basic idea--- is that, since we don't know what an InstalledPackageId is--- beforehand, we just fake up one based on the package ID (it only--- needs to be unique for the particular install plan), and fill--- it out with the actual generated InstalledPackageId after the--- package is successfully compiled.------ However, there is a problem: in the index there may be--- references using the old package ID, which are now dangling if--- we update the InstalledPackageId.  We could map over the entire--- index to update these pointers as well (a costly operation), but--- instead, we've chosen to parametrize a variety of important functions--- by a FakeMap, which records what a fake installed package ID was--- actually resolved to post-compilation.  If we do a lookup, we first--- check and see if it's a fake ID in the FakeMap.------ It's a bit grungy, but we expect this to only be temporary anyway.--- (Another possible workaround would have been to *not* update--- the installed package ID, but I decided this would be hard to--- understand.)---- | Map from fake installed package IDs to real ones.  See Note [FakeMap]-type FakeMap = Map InstalledPackageId InstalledPackageId---- | 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 'InstalledPackageId', 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 InstalledPackageId.-  ---  !(Map InstalledPackageId 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 InstalledPackageId-  -- and are kept in preference order.-  ---  -- FIXME: Clarify what "preference order" means. Check that this invariant is-  -- preserved. See #1463 for discussion.-  !(Map PackageName (Map Version [a]))--  deriving (Generic, Show, Read)--instance Binary a => Binary (PackageIndex a)---- | The default package index which contains 'InstalledPackageInfo'.  Normally--- use this.-type InstalledPackageIndex = PackageIndex InstalledPackageInfo--instance PackageInstalled a => Monoid (PackageIndex a) 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 :: PackageInstalled a => PackageIndex a -> 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 :: PackageInstalled a-               => Map InstalledPackageId a-               -> Map PackageName (Map Version [a])-               -> PackageIndex a-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 :: PackageInstalled a => [a] -> PackageIndex a-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 :: PackageInstalled a => PackageIndex a -> PackageIndex a -> PackageIndex a-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 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 :: PackageInstalled a => a -> PackageIndex a -> PackageIndex a-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 :: PackageInstalled a => InstalledPackageId -> PackageIndex a -> PackageIndex a-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 :: PackageInstalled a => PackageId -> PackageIndex a -> PackageIndex a-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 :: PackageInstalled a => PackageName -> PackageIndex a -> PackageIndex a-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 a -> [a]-allPackages (PackageIndex pids _) = Map.elems pids---- | Get all the packages from the index.------ They are grouped by package name (case-sensitively).----allPackagesByName :: PackageIndex a -> [(PackageName, [a])]-allPackagesByName (PackageIndex _ pnames) =-  [ (pkgname, concat (Map.elems pvers))-  | (pkgname, pvers) <- Map.toList pnames ]---- | Get all the packages from the index.------ They are grouped by source package id (package name and version).----allPackagesBySourcePackageId :: PackageInstalled a => PackageIndex a -> [(PackageId, [a])]-allPackagesBySourcePackageId (PackageIndex _ pnames) =-  [ (packageId ipkg, ipkgs)-  | pvers <- Map.elems pnames-  , ipkgs@(ipkg:_) <- Map.elems pvers ]------- * 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 :: PackageInstalled a => PackageIndex a -> InstalledPackageId-                         -> Maybe a-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 :: PackageInstalled a => PackageIndex a -> PackageId -> [a]-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---- | Convenient alias of 'lookupSourcePackageId', but assuming only--- one package per package ID.-lookupPackageId :: PackageInstalled a => 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 :: PackageInstalled a => PackageIndex a -> PackageName-                  -> [(Version, [a])]-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 :: PackageInstalled a => PackageIndex a -> Dependency-                 -> [(Version, [a])]-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-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 :: PackageInstalled a => PackageIndex a -> String -> SearchResult [a]-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 :: PackageInstalled a => PackageIndex a -> String -> [a]-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 :: PackageInstalled a => PackageIndex a -> [[a]]-dependencyCycles = dependencyCycles' Map.empty---- | Variant of 'dependencyCycles' which accepts a 'FakeMap'.  See Note [FakeMap].-dependencyCycles' :: PackageInstalled a => FakeMap -> PackageIndex a -> [[a]]-dependencyCycles' fakeMap index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, installedPackageId pkg, fakeInstalledDepends fakeMap 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, [InstalledPackageId])]-brokenPackages = brokenPackages' Map.empty---- | Variant of 'brokenPackages' which accepts a 'FakeMap'.  See Note [FakeMap].-brokenPackages' :: PackageInstalled a => FakeMap -> PackageIndex a -> [(a, [InstalledPackageId])]-brokenPackages' fakeMap index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- installedDepends pkg-                         , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ]-  , not (null missing) ]---- | Variant of 'lookupInstalledPackageId' which accepts a 'FakeMap'.  See Note [FakeMap].-fakeLookupInstalledPackageId :: PackageInstalled a => FakeMap -> PackageIndex a -> InstalledPackageId -> Maybe a-fakeLookupInstalledPackageId fakeMap index pkg = lookupInstalledPackageId index (Map.findWithDefault pkg pkg fakeMap)---- | 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 :: PackageInstalled a => PackageIndex a-                  -> [InstalledPackageId]-                  -> Either (PackageIndex a)-                            [(a, [InstalledPackageId])]-dependencyClosure = dependencyClosure' Map.empty---- | Variant of 'dependencyClosure' which accepts a 'FakeMap'.  See Note [FakeMap].-dependencyClosure' :: PackageInstalled a => FakeMap-                  -> PackageIndex a-                  -> [InstalledPackageId]-                  -> Either (PackageIndex a)-                            [(a, [InstalledPackageId])]-dependencyClosure' fakeMap 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 fakeLookupInstalledPackageId fakeMap index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case fakeLookupInstalledPackageId fakeMap completed (installedPackageId 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-                         -> [InstalledPackageId]-                         -> [a]-reverseDependencyClosure = reverseDependencyClosure' Map.empty---- | Variant of 'reverseDependencyClosure' which accepts a 'FakeMap'.  See Note [FakeMap].-reverseDependencyClosure' :: PackageInstalled a => FakeMap-                         -> PackageIndex a-                         -> [InstalledPackageId]-                         -> [a]-reverseDependencyClosure' fakeMap index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)--  where-    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph' fakeMap 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,-                    InstalledPackageId -> Maybe Graph.Vertex)-dependencyGraph = dependencyGraph' Map.empty---- | Variant of 'dependencyGraph' which accepts a 'FakeMap'.  See Note [FakeMap].-dependencyGraph' :: PackageInstalled a => FakeMap-                -> PackageIndex a-                -> (Graph.Graph,-                    Graph.Vertex -> a,-                    InstalledPackageId -> Maybe Graph.Vertex)-dependencyGraph' fakeMap 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 installedPackageId pkgs) [0..]-    vertex_map       = Map.fromList vertices-    id_to_vertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) 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 :: PackageInstalled a => PackageIndex a-                          -> [(PackageName, [(PackageId, Version)])]-dependencyInconsistencies = dependencyInconsistencies' Map.empty---- | Variant of 'dependencyInconsistencies' which accepts a 'FakeMap'.  See Note [FakeMap].-dependencyInconsistencies' :: PackageInstalled a => FakeMap -> PackageIndex a-                          -> [(PackageName, [(PackageId, Version)])]-dependencyInconsistencies' fakeMap 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.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))-          [ (packageName dep,-             Map.fromList [(ipid,(dep,[packageId pkg]))])-          | pkg <- allPackages index-          , ipid <- fakeInstalledDepends fakeMap pkg-          , Just dep <- [fakeLookupInstalledPackageId fakeMap index ipid]-          ]--        reallyIsInconsistent :: PackageInstalled a => [a] -> Bool-        reallyIsInconsistent []       = False-        reallyIsInconsistent [_p]     = False-        reallyIsInconsistent [p1, p2] =-          let pid1 = installedPackageId p1-              pid2 = installedPackageId p2-          in Map.findWithDefault pid1 pid1 fakeMap `notElem` fakeInstalledDepends fakeMap p2-          && Map.findWithDefault pid2 pid2 fakeMap `notElem` fakeInstalledDepends fakeMap p1-        reallyIsInconsistent _ = True---- | Variant of 'installedDepends' which accepts a 'FakeMap'.  See Note [FakeMap].-fakeInstalledDepends :: PackageInstalled a => FakeMap -> a -> [InstalledPackageId]-fakeInstalledDepends fakeMap = map (\pid -> Map.findWithDefault pid pid fakeMap) . installedDepends---- | 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 [InstalledPackageInfo]-moduleNameIndex index =-  Map.fromListWith (++) $ do-    pkg <- allPackages index-    IPI.ExposedModule m reexport _ <- IPI.exposedModules pkg-    case reexport of-        Nothing -> return (m, [pkg])-        Just (IPI.OriginalModule _ 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!
− Distribution/Simple/PreProcess.hs 
@@ -1,620 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.PreProcess--- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This defines a 'PreProcessor' abstraction which represents a pre-processor--- that can transform one kind of file into another. There is also a--- 'PPSuffixHandler' which is a combination of a file extension and a function--- for configuring a 'PreProcessor'. It defines a bunch of known built-in--- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and--- lists them in 'knownSuffixHandlers'. On top of this it provides a function--- for actually preprocessing some sources given a bunch of known suffix--- handlers. This module is not as good as it could be, it could really do with--- a rewrite to address some of the problems we have with pre-processors.--module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,-                                ppSuffixes, PPSuffixHandler, PreProcessor(..),-                                mkSimplePreProcessor, runSimplePreProcessor,-                                ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,-                                ppHappy, ppAlex, ppUnlit, platformDefines-                               )-    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.CCompiler-         ( cSourceExtensions )-import Distribution.Simple.Compiler-         ( CompilerFlavor(..)-         , compilerFlavor, compilerCompatVersion, compilerVersion )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), Component(..) )-import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)-import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile-         , findFileWithExtension, findFileWithExtension' )-import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), programPath-         , requireProgram, requireProgramVersion-         , rawSystemProgramConf, rawSystemProgram-         , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram-         , happyProgram, alexProgram, ghcProgram, ghcjsProgram, gccProgram )-import Distribution.Simple.Test.LibV09-         ( writeSimpleTestStub, stubFilePath, stubName )-import Distribution.System-         ( OS(..), buildOS, Arch(..), Platform(..) )-import Distribution.Text-import Distribution.Version-         ( Version(..), anyVersion, orLaterVersion )-import Distribution.Verbosity--import Data.Maybe (fromMaybe)-import Data.List (nub)-import System.Directory (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 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-  -- 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-    builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]-    builtinCSuffixes       = cSourceExtensions-    builtinSuffixes        = builtinHaskellSuffixes ++ builtinCSuffixes-    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 dir 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 ->-                              psrcFile `moreRecentFile` ppsrcFile-              when recomp $ do-                let destDir = buildLoc </> dirName srcStem-                createDirectoryIfMissingVerbose verbosity True destDir-                runPreProcessorWithHsBootHack pp-                   (psrcLoc, psrcRelFile)-                   (buildLoc, srcStem <.> "hs")--  where-    dirName = takeDirectory-    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 ghcProgram   (>= Version [6,6] []) args bi lbi-    GHCJS -> ppGhcCpp ghcjsProgram (const True)          args bi lbi-    _     -> ppCpphs  args bi lbi-  where cppArgs = getCppOptions bi lbi-        args    = cppArgs ++ extraArgs--ppGhcCpp :: Program -> (Version -> Bool)-         -> [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor-ppGhcCpp program xHs extraArgs _bi lbi =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do-      (prog, version, _) <- requireProgramVersion verbosity-                              program anyVersion (withPrograms lbi)-      rawSystemProgram verbosity prog $-          ["-E", "-cpp"]-          -- This is a bit of an ugly hack. We're going to-          -- unlit the file ourselves later on if appropriate,-          -- so we need GHC not to unlit it now or it'll get-          -- double-unlitted. In the future we might switch to-          -- using cpphs --unlit instead.-       ++ (if xHs version then ["-x", "hs"] else [])-       ++ [ "-optP-include", "-optP"++ (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-  }--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 <- platformDefines lbi ]--          -- Options from the current package:-       ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]-       ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi-                                      ++ PD.cppOptions   bi ]-       ++ [ "--cflag="   ++ opt | opt <--               [ "-I" ++ autogenModulesDir lbi,-                 "-include", autogenModulesDir lbi </> cppHeaderName ] ]-       ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]-       ++ [ "--lflag=-Wl,-R," ++ opt | isELF-                                , opt <- PD.extraLibDirs bi ]-       ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs    bi ]-       ++ [ "--lflag="   ++ opt | opt <- PD.ldOptions    bi ]--          -- Options from dependent packages-       ++ [ "--cflag=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt <- Installed.ccOptions   pkg ] ]-       ++ [ "--lflag=" ++ opt-          | pkg <- pkgs-          , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]-                ++ [ "-Wl,-R," ++ opt | isELF-                                 , opt <- Installed.libraryDirs    pkg ]-                ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ]-                ++ [         opt | opt <- Installed.ldOptions      pkg ] ]-       ++ ["-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-      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 (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-    = platformDefines lbi-   ++ cppOptions bi-   ++ ["-I" ++ dir | dir <- PD.includeDirs bi]-   ++ [opt | opt@('-':c:_) <- PD.ccOptions 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-    JHC  -> ["-D__JHC__=" ++ versionInt version]-    HaskellSuite {} ->-      ["-D__HASKELL_SUITE__"] ++-        map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr ++-        map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr-    _    -> []-  where-    comp = compiler lbi-    Platform hostArch hostOS = hostPlatform lbi-    version = compilerVersion comp-    compatGlasgowHaskell =-      maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])-               (compilerCompatVersion GHC comp)-    -- TODO: move this into the compiler abstraction-    -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all-    -- the other compilers. Check if that's really what they want.-    versionInt :: Version -> String-    versionInt (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-    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"]-      Ghcjs     -> ["ghcjs"]-      OtherOS _ -> []-    archStr = case hostArch of-      I386        -> ["i386"]-      X86_64      -> ["x86_64"]-      PPC         -> ["powerpc"]-      PPC64       -> ["powerpc64"]-      Sparc       -> ["sparc"]-      Arm         -> ["arm"]-      Mips        -> ["mips"]-      SH          -> []-      IA64        -> ["ia64"]-      S390        -> ["s390"]-      Alpha       -> ["alpha"]-      Hppa        -> ["hppa"]-      Rs6000      -> ["rs6000"]-      M68k        -> ["m68k"]-      Vax         -> ["vax"]-      JavaScript  -> ["javascript"]-      OtherArch _ -> []--ppHappy :: BuildInfo -> LocalBuildInfo -> 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 -> PreProcessor-ppAlex _ lbi = pp { platformIndependent = True }-  where pp = standardPP lbi alexProgram (hcFlags hc)-        hc = compilerFlavor (compiler lbi)-        hcFlags GHC = ["-g"]-        hcFlags GHCJS = ["-g"]-        hcFlags _ = []--standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor-standardPP lbi prog args =-  PreProcessor {-    platformIndependent = False,-    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->-      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,222 +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(..)-    , ProgramSearchPath-    , ProgramSearchPathEntry(..)-    , simpleProgram-    , findProgramLocation-    , findProgramVersion--    -- * Configured program and related functions-    , ConfiguredProgram(..)-    , programPath-    , ProgArg-    , ProgramLocation(..)-    , runProgram-    , getProgramOutput-    , suppressOverrideArgs--    -- * Program invocations-    , ProgramInvocation(..)-    , emptyProgramInvocation-    , simpleProgramInvocation-    , programInvocation-    , runProgramInvocation-    , getProgramInvocationOutput--    -- * The collection of unconfigured and configured programs-    , builtinPrograms--    -- * The collection of configured programs we can run-    , ProgramConfiguration-    , emptyProgramConfiguration-    , defaultProgramConfiguration-    , restoreProgramConfiguration-    , addKnownProgram-    , addKnownPrograms-    , lookupKnownProgram-    , knownPrograms-    , getProgramSearchPath-    , setProgramSearchPath-    , userSpecifyPath-    , userSpecifyPaths-    , userMaybeSpecifyPath-    , userSpecifyArgs-    , userSpecifyArgss-    , userSpecifiedArgs-    , lookupProgram-    , lookupProgramVersion-    , updateProgram-    , configureProgram-    , configureAllKnownPrograms-    , reconfigurePrograms-    , requireProgram-    , requireProgramVersion-    , runDbProgram-    , getDbProgramOutput--    -- * Programs that Cabal knows about-    , ghcProgram-    , ghcPkgProgram-    , ghcjsProgram-    , ghcjsPkgProgram-    , lhcProgram-    , lhcPkgProgram-    , hmakeProgram-    , jhcProgram-    , uhcProgram-    , gccProgram-    , 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,169 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------------------------- |--- 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 Control.Monad (when, unless)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Data.Char (isSpace)-import Distribution.Compat.CopyFile (filesEqual)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))-import Distribution.Simple.Program-         ( arProgram, requireProgram )-import Distribution.Simple.Program.Run-         ( programInvocation, multiStageProgramInvocation-         , runProgramInvocation )-import qualified Distribution.Simple.Program.Strip as Strip-         ( stripLib )-import Distribution.Simple.Utils-         ( dieWithLocation, withTempDirectory )-import Distribution.System-         ( Arch(..), OS(..), Platform(..) )-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-                   -> FilePath -> [FilePath] -> IO ()-createArLibArchive verbosity lbi targetPath files = do-  (ar, _) <- requireProgram verbosity arProgram progConf--  let (targetDir, targetName) = splitFileName targetPath-  withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do-  let tmpPath = tmpDir </> targetName--  -- The args to use with "ar" are actually rather subtle and system-dependent.-  -- In particular we have the following issues:-  ---  --  -- On OS X, "ar q" does not make an archive index. Archives with no-  --     index cannot be used.-  ---  --  -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us-  --     do that. We have duplicates because of modules like "A.M" and "B.M"-  --     both make an object file "M.o" and ar does not consider the directory.-  ---  -- Our solution is to use "ar r" in the simple case when one call is enough.-  -- When we need to call ar multiple times we use "ar q" and for the last-  -- call on OSX we use "ar qs" so that it'll make the index.--  let simpleArgs  = case hostOS of-             OSX -> ["-r", "-s"]-             _   -> ["-r"]--      initialArgs = ["-q"]-      finalArgs   = case hostOS of-             OSX -> ["-q", "-s"]-             _   -> ["-q"]--      extraArgs   = verbosityOpts verbosity ++ [tmpPath]--      simple  = programInvocation ar (simpleArgs  ++ extraArgs)-      initial = programInvocation ar (initialArgs ++ extraArgs)-      middle  = initial-      final   = programInvocation ar (finalArgs   ++ extraArgs)--  sequence_-        [ runProgramInvocation verbosity inv-        | inv <- multiStageProgramInvocation-                   simple (initial, middle, final) files ]--  when stripLib $ Strip.stripLib verbosity platform progConf tmpPath-  unless (hostArch == Arm) $ -- See #1537-    wipeMetadata tmpPath-  equal <- filesEqual tmpPath targetPath-  unless equal $ renameFile tmpPath targetPath--  where-    progConf = withPrograms lbi-    stripLib = stripLibs    lbi-    platform@(Platform hostArch hostOS) = hostPlatform lbi-    verbosityOpts v | v >= deafening = ["-v"]-                    | v >= verbose   = []-                    | otherwise      = ["-c"]---- | @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 :: FilePath -> IO ()-wipeMetadata 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 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
− Distribution/Simple/Program/Builtin.hs 
@@ -1,362 +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 programs-    builtinPrograms,--    -- * Programs that Cabal knows about-    ghcProgram,-    ghcPkgProgram,-    ghcjsProgram,-    ghcjsPkgProgram,-    lhcProgram,-    lhcPkgProgram,-    hmakeProgram,-    jhcProgram,-    haskellSuiteProgram,-    haskellSuitePkgProgram,-    uhcProgram,-    gccProgram,-    arProgram,-    stripProgram,-    happyProgram,-    alexProgram,-    hsc2hsProgram,-    c2hsProgram,-    cpphsProgram,-    hscolourProgram,-    haddockProgram,-    greencardProgram,-    ldProgram,-    tarProgram,-    cppProgram,-    pkgConfigProgram,-    hpcProgram,-  ) where--import Distribution.Simple.Program.Find-         ( findProgramOnSearchPath )-import Distribution.Simple.Program.Run-         ( getProgramInvocationOutput, programInvocation )-import Distribution.Simple.Program.Types-         ( Program(..), ConfiguredProgram(..), simpleProgram )-import Distribution.Simple.Utils-         ( findProgramVersion )-import Distribution.Compat.Exception-         ( catchIO )-import Distribution.Verbosity-         ( lessVerbose )-import Distribution.Version-         ( Version(..), withinRange, earlierVersion, laterVersion-         , intersectVersionRanges )-import Data.Char-         ( isDigit )--import Data.List-         ( isInfixOf )-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-    , ghcPkgProgram-    , ghcjsProgram-    , ghcjsPkgProgram-    , haskellSuiteProgram-    , haskellSuitePkgProgram-    , hmakeProgram-    , jhcProgram-    , lhcProgram-    , lhcPkgProgram-    , uhcProgram-    , hpcProgram-    -- preprocessors-    , hscolourProgram-    , haddockProgram-    , happyProgram-    , alexProgram-    , hsc2hsProgram-    , c2hsProgram-    , cpphsProgram-    , greencardProgram-    -- platform toolchain-    , gccProgram-    , arProgram-    , stripProgram-    , ldProgram-    , tarProgram-    -- configuration tools-    , pkgConfigProgram-    ]--ghcProgram :: Program-ghcProgram = (simpleProgram "ghc") {-    programFindVersion = findProgramVersion "--numeric-version" id,--    -- Workaround for https://ghc.haskell.org/trac/ghc/ticket/8825-    -- (spurious warning on non-english locales)-    programPostConf    = \_verbosity ghcProg ->-    do let ghcProg' = ghcProg {-             programOverrideEnv = ("LANGUAGE", Just "en")-                                  : programOverrideEnv ghcProg-             }-           -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4.-           affectedVersionRange = intersectVersionRanges-                                  (laterVersion   $ Version [7,8,0] [])-                                  (earlierVersion $ Version [7,8,4] [])-       return $ maybe ghcProg-         (\v -> if withinRange v affectedVersionRange-                then ghcProg' else ghcProg)-         (programVersion ghcProg)-  }--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-        _               -> ""-  }--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-        _               -> ""-  }--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-                _ -> ""-    }---- This represents a haskell-suite compiler. Of course, the compiler--- itself probably is not called "haskell-suite", so this is not a real--- program. (But we don't know statically the name of the actual compiler,--- so this is the best we can do.)------ Having this Program value serves two purposes:------ 1. We can accept options for the compiler in the form of------   --haskell-suite-option(s)=...------ 2. We can find a program later using this static id (with--- requireProgram).------ The path to the real compiler is found and recorded in the ProgramDb--- during the configure phase.-haskellSuiteProgram :: Program-haskellSuiteProgram = (simpleProgram "haskell-suite") {-    -- pretend that the program exists, otherwise it won't be in the-    -- "configured" state-    programFindLocation =-      \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location"-  }---- This represent a haskell-suite package manager. See the comments for--- haskellSuiteProgram.-haskellSuitePkgProgram :: Program-haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {-    programFindLocation =-      \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location"-  }---happyProgram :: Program-happyProgram = (simpleProgram "happy") {-    programFindVersion = findProgramVersion "--version" $ \str ->-      -- Invoking "happy --version" gives a string like-      -- "Happy Version 1.16 Copyright (c) ...."-      case words str of-        (_:_:ver:_) -> ver-        _           -> ""-  }--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-  }--arProgram :: Program-arProgram = simpleProgram "ar"--stripProgram :: Program-stripProgram = (simpleProgram "strip") {-    programFindVersion = \verbosity ->-      findProgramVersion "--version" selectVersion (lessVerbose verbosity)-  }-  where-    selectVersion str =-      -- Invoking "strip --version" gives very inconsistent-      -- results. We look for the first word that starts with a-      -- number, and try parsing out the first two components of-      -- it. Non-GNU 'strip' doesn't appear to have a version flag.-      let numeric ""    = False-          numeric (x:_) = isDigit x-      in case dropWhile (not . numeric) (words str) of-        (ver:_) ->-          -- take the first two version components-          let isDot         = (== '.')-              (major, rest) = break isDot ver-              minor         = takeWhile (not . isDot) (dropWhile isDot rest)-          in major ++ "." ++ minor-        _ -> ""--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-        _         -> ""-  }--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") {-  -- 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-  }
− Distribution/Simple/Program/Db.hs 
@@ -1,471 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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,-    getProgramSearchPath,-    setProgramSearchPath,-    modifyProgramSearchPath,-    userSpecifyPath,-    userSpecifyPaths,-    userMaybeSpecifyPath,-    userSpecifyArgs,-    userSpecifyArgss,-    userSpecifiedArgs,-    lookupProgram,-    updateProgram,-    configuredPrograms,--    -- ** Query and manipulate the program db-    configureProgram,-    configureAllKnownPrograms,-    lookupProgramVersion,-    reconfigurePrograms,-    requireProgram,-    requireProgramVersion,--  ) where--import Distribution.Simple.Program.Types-         ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )-import Distribution.Simple.Program.Find-         ( ProgramSearchPath, defaultProgramSearchPath-         , findProgramOnSearchPath, programSearchPathAsPATHVar )-import Distribution.Simple.Program.Builtin-         ( builtinPrograms )-import Distribution.Simple.Utils-         ( die, doesExecutableExist )-import Distribution.Version-         ( Version, VersionRange, isAnyVersion, withinRange )-import Distribution.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity )--import Distribution.Compat.Binary (Binary(..))-#if __GLASGOW_HASKELL__ < 710-import Data.Functor ((<$>))-#endif-import Data.List-         ( foldl' )-import Data.Maybe-         ( catMaybes )-import qualified Data.Map as Map-import Control.Monad-         ( join, foldM )---- --------------------------------------------------------------- * 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,-        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 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 ]--instance Binary ProgramDb where-  put = put . configuredProgs-  get = do-      progs <- get-      return $! emptyProgramDb { configuredProgs = progs }----- | 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) ]---- | 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---- |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----- | List all configured programs.-configuredPrograms :: ProgramDb -> [ConfiguredProgram]-configuredPrograms = Map.elems . configuredProgs---- ------------------------------ Configuring known programs---- | Try to configure a specific program. If the program is already included in--- the collection of unconfigured programs then we use any user-supplied--- location and arguments. If the program gets configured successfully it gets--- added to the configured collection.------ 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 conf = do-  let name = programName prog-  maybeLocation <- case userSpecifiedPath prog conf of-    Nothing   -> programFindLocation prog verbosity (progSearchPath conf)-             >>= return . fmap FoundOnSystem-    Just path -> do-      absolute <- doesExecutableExist path-      if absolute-        then return (Just (UserSpecified path))-        else findProgramOnSearchPath verbosity (progSearchPath conf) path-         >>= maybe (die notFound) (return . Just . UserSpecified)-      where notFound = "Cannot find the program '" ++ name-                     ++ "'. User-specified path '"-                     ++ path ++ "' does not refer to an executable and "-                     ++ "the program is not on the system path."-  case maybeLocation of-    Nothing -> return conf-    Just location -> do-      version <- programFindVersion prog verbosity (locationPath location)-      newPath <- programSearchPathAsPATHVar (progSearchPath conf)-      let configuredProg        = ConfiguredProgram {-            programId           = name,-            programVersion      = version,-            programDefaultArgs  = [],-            programOverrideArgs = userSpecifiedArgs prog conf,-            programOverrideEnv  = [("PATH", Just newPath)],-            programProperties   = Map.empty,-            programLocation     = location-          }-      configuredProg' <- programPostConf prog verbosity configuredProg-      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 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 String (ConfiguredProgram, Version, ProgramDb))-lookupProgramVersion verbosity prog range programDb = do--  -- If it's not already been configured, try to configure it now-  programDb' <- case lookupProgram prog programDb of-    Nothing -> configureProgram verbosity prog programDb-    Just _  -> return programDb--  case lookupProgram prog programDb' of-    Nothing                           -> return $! Left notFound-    Just configuredProg@ConfiguredProgram { programLocation = location } ->-      case programVersion configuredProg of-        Just version-          | withinRange version range ->-            return $! Right (configuredProg, version ,programDb')-          | otherwise                 ->-            return $! Left (badVersion version location)-        Nothing                       ->-          return $! Left (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---- | 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 die return <$>-  lookupProgramVersion verbosity prog range programDb
− Distribution/Simple/Program/Find.hs 
@@ -1,126 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Program.Types--- 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,-  ) where--import Distribution.Verbosity-         ( Verbosity )-import Distribution.Simple.Utils-         ( debug, doesExecutableExist )-import Distribution.System-         ( OS(..), buildOS )-import System.Directory-         ( findExecutable )-import Distribution.Compat.Environment-         ( getEnvironment )-import System.FilePath-         ( (</>), (<.>), splitSearchPath, searchPathSeparator )-import Data.List-         ( intercalate )----- | A search path to use when locating executables. This is analogous--- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use--- the system default method for finding executables ('findExecutable' which--- on unix is simply looking on the @$PATH@ but on win32 is a bit more--- complicated).------ The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs--- either before, after or instead of the default, e.g. here we add an extra--- dir to search after the usual ones.------ > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]----type ProgramSearchPath = [ProgramSearchPathEntry]-data ProgramSearchPathEntry =-         ProgramSearchPathDir FilePath  -- ^ A specific dir-       | ProgramSearchPathDefault       -- ^ The system default--defaultProgramSearchPath :: ProgramSearchPath-defaultProgramSearchPath = [ProgramSearchPathDefault]--findProgramOnSearchPath :: Verbosity -> ProgramSearchPath-                        -> FilePath -> IO (Maybe 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 []       = return Nothing-    tryPathElems (pe:pes) = do-      res <- tryPathElem pe-      case res of-        Nothing -> tryPathElems pes-        Just _  -> return res--    tryPathElem (ProgramSearchPathDir dir) =-        findFirstExe [ dir </> prog <.> ext | ext <- extensions ]-      where-        -- Possible improvement: on Windows, read the list of extensions from-        -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe;-        -- .bat; .cmd".-        extensions = case buildOS of-                       Windows -> ["", "exe"]-                       Ghcjs   -> ["", "exe"]-                       _       -> [""]--    tryPathElem ProgramSearchPathDefault = do-      -- 'findExecutable' doesn't check that the path really refers to an-      -- executable on Windows (at least with GHC < 7.8). See-      -- https://ghc.haskell.org/trac/ghc/ticket/2184-      mExe <- findExecutable prog-      case mExe of-        Just exe -> do-          exeExists <- doesExecutableExist exe-          if exeExists-            then return mExe-            else return Nothing-        _        -> return mExe--    findFirstExe []     = return Nothing-    findFirstExe (f:fs) = do-      isExe <- doesExecutableExist f-      if isExe-        then return (Just f)-        else findFirstExe fs---- | 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 <- mapM getEntries searchpath-    return (intercalate [searchPathSeparator] (concat ess))-  where-    getEntries (ProgramSearchPathDir dir) = return [dir]-    getEntries ProgramSearchPathDefault   = do-      env <- getEnvironment-      return (maybe [] splitSearchPath (lookup "PATH" env))
− Distribution/Simple/Program/GHC.hs 
@@ -1,562 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Simple.Program.GHC (-    GhcOptions(..),-    GhcMode(..),-    GhcOptimisation(..),-    GhcDynLinkMode(..),--    ghcInvocation,-    renderGhcOptions,--    runGHC,--  ) where--import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) )-import Distribution.Package-import Distribution.PackageDescription hiding (Flag)-import Distribution.ModuleName-import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.Setup    ( Flag(..), flagToMaybe, fromFlagOrDefault,-                                      flagToList )-import Distribution.Simple.Program.Types-import Distribution.Simple.Program.Run-import Distribution.Text-import Distribution.Verbosity-import Distribution.Utils.NubList   ( NubListR, fromNubListR )-import Language.Haskell.Extension   ( Language(..), Extension(..) )--import qualified Data.Map as M-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif-import Data.List ( intercalate )---- | A structured set of GHC options/flags----data GhcOptions = GhcOptions {--  -- | The major mode for the ghc invocation.-  ghcOptMode          :: Flag GhcMode,--  -- | Any extra options to pass directly to ghc. These go at the end and hence-  -- override other stuff.-  ghcOptExtra         :: NubListR String,--  -- | Extra default flags to pass directly to ghc. These go at the beginning-  -- and so can be overridden by other stuff.-  ghcOptExtraDefault  :: NubListR String,--  ------------------------  -- Inputs and outputs--  -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.-  ghcOptInputFiles    :: NubListR FilePath,--  -- | The names of input Haskell modules, mainly for @--make@ mode.-  ghcOptInputModules  :: NubListR ModuleName,--  -- | Location for output file; the @ghc -o@ flag.-  ghcOptOutputFile    :: Flag FilePath,--  -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;-  -- the @ghc -dyno@ flag.-  ghcOptOutputDynFile :: Flag FilePath,--  -- | Start with an empty search path for Haskell source files;-  -- the @ghc -i@ flag (@-i@ on it's own with no path argument).-  ghcOptSourcePathClear :: Flag Bool,--  -- | Search path for Haskell source files; the @ghc -i@ flag.-  ghcOptSourcePath    :: NubListR FilePath,--  --------------  -- Packages--  -- | The package key the modules will belong to; the @ghc -this-package-key@-  -- flag.-  ghcOptPackageKey   :: Flag PackageKey,--  -- | GHC package databases to use, the @ghc -package-conf@ flag.-  ghcOptPackageDBs    :: PackageDBStack,--  -- | The GHC packages to use. For compatability with old and new ghc, this-  -- requires both the short and long form of the package id;-  -- the @ghc -package@ or @ghc -package-id@ flags.-  ghcOptPackages      ::-    NubListR (InstalledPackageId, PackageId, ModuleRenaming),--  -- | Start with a clean package set; the @ghc -hide-all-packages@ flag-  ghcOptHideAllPackages :: Flag Bool,--  -- | Don't automatically link in Haskell98 etc; the @ghc-  -- -no-auto-link-packages@ flag.-  ghcOptNoAutoLinkPackages :: Flag Bool,--  -- | What packages are implementing the signatures-  ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))],--  ------------------  -- Linker stuff--  -- | Names of libraries to link in; the @ghc -l@ flag.-  ghcOptLinkLibs      :: NubListR FilePath,--  -- | Search path for libraries to link in; the @ghc -L@ flag.-  ghcOptLinkLibPath  :: NubListR FilePath,--  -- | Options to pass through to the linker; the @ghc -optl@ flag.-  ghcOptLinkOptions   :: NubListR String,--  -- | OSX only: frameworks to link in; the @ghc -framework@ flag.-  ghcOptLinkFrameworks :: NubListR String,--  -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.-  ghcOptNoLink :: Flag Bool,--  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@-  -- flag.-  ghcOptLinkNoHsMain :: Flag Bool,--  ---------------------  -- C and CPP stuff--  -- | Options to pass through to the C compiler; the @ghc -optc@ flag.-  ghcOptCcOptions     :: NubListR String,--  -- | Options to pass through to CPP; the @ghc -optP@ flag.-  ghcOptCppOptions    :: NubListR String,--  -- | Search path for CPP includes like header files; the @ghc -I@ flag.-  ghcOptCppIncludePath :: NubListR FilePath,--  -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.-  ghcOptCppIncludes    :: NubListR FilePath,--  -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.-  ghcOptFfiIncludes    :: NubListR FilePath,--  -----------------------------  -- Language and extensions--  -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.-  ghcOptLanguage      :: Flag Language,--  -- | The language extensions; the @ghc -X@ flag.-  ghcOptExtensions    :: NubListR Extension,--  -- | A GHC version-dependent mapping of extensions to flags. This must be-  -- set to be able to make use of the 'ghcOptExtensions'.-  ghcOptExtensionMap    :: M.Map Extension String,--  -----------------  -- Compilation--  -- | What optimisation level to use; the @ghc -O@ flag.-  ghcOptOptimisation  :: Flag GhcOptimisation,--    -- | Emit debug info; the @ghc -g@ flag.-  ghcOptDebugInfo  :: Flag Bool,--  -- | Compile in profiling mode; the @ghc -prof@ flag.-  ghcOptProfilingMode :: Flag Bool,--  -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.-  ghcOptSplitObjs     :: Flag Bool,--  -- | Run N jobs simultaneously (if possible).-  ghcOptNumJobs       :: Flag (Maybe Int),--  -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.-  ghcOptHPCDir        :: Flag FilePath,--  -----------------  -- GHCi--  -- | Extra GHCi startup scripts; the @-ghci-script@ flag-  ghcOptGHCiScripts    :: NubListR FilePath,--  -------------------------  -- Redirecting outputs--  ghcOptHiSuffix      :: Flag String,-  ghcOptObjSuffix     :: Flag String,-  ghcOptDynHiSuffix   :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode-  ghcOptDynObjSuffix  :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode-  ghcOptHiDir         :: Flag FilePath,-  ghcOptObjDir        :: Flag FilePath,-  ghcOptOutputDir     :: Flag FilePath,-  ghcOptStubDir       :: Flag FilePath,--  ---------------------  -- Dynamic linking--  ghcOptDynLinkMode   :: Flag GhcDynLinkMode,-  ghcOptShared        :: Flag Bool,-  ghcOptFPic          :: Flag Bool,-  ghcOptDylibName     :: Flag String,-  ghcOptRPaths        :: NubListR FilePath,--  ----------------  -- Misc flags--  -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.-  ghcOptVerbosity     :: Flag Verbosity,--  -- | Let GHC know that it is Cabal that's calling it.-  -- Modifies some of the GHC error messages.-  ghcOptCabal         :: Flag Bool--} deriving Show---data GhcMode = GhcModeCompile     -- ^ @ghc -c@-             | GhcModeLink        -- ^ @ghc@-             | GhcModeMake        -- ^ @ghc --make@-             | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@-             | GhcModeAbiHash     -- ^ @ghc --abi-hash@---             | GhcModeDepAnalysis -- ^ @ghc -M@---             | GhcModeEvaluate    -- ^ @ghc -e@- deriving (Show, Eq)--data GhcOptimisation = GhcNoOptimisation             -- ^ @-O0@-                     | GhcNormalOptimisation         -- ^ @-O@-                     | GhcMaximumOptimisation        -- ^ @-O2@-                     | GhcSpecialOptimisation String -- ^ e.g. @-Odph@- deriving (Show, Eq)--data GhcDynLinkMode = GhcStaticOnly       -- ^ @-static@-                    | GhcDynamicOnly      -- ^ @-dynamic@-                    | GhcStaticAndDynamic -- ^ @-static -dynamic-too@- deriving (Show, Eq)---runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO ()-runGHC verbosity ghcProg comp opts = do-  runProgramInvocation verbosity (ghcInvocation ghcProg comp opts)---ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation-ghcInvocation prog comp opts =-    programInvocation prog (renderGhcOptions comp opts)--renderGhcOptions :: Compiler -> GhcOptions -> [String]-renderGhcOptions comp 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]--  , flags ghcOptExtraDefault--  , [ "-no-link" | flagBool ghcOptNoLink ]--  ----------------  -- Misc flags--  , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))--  , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal-                                 , flagBuildingCabalPkg implInfo ]--  -----------------  -- Compilation--  , case flagToMaybe (ghcOptOptimisation opts) of-      Nothing                         -> []-      Just GhcNoOptimisation          -> ["-O0"]-      Just GhcNormalOptimisation      -> ["-O"]-      Just GhcMaximumOptimisation     -> ["-O2"]-      Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph--  , [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ]--  , [ "-prof" | flagBool ghcOptProfilingMode ]--  , [ "-split-objs" | flagBool ghcOptSplitObjs ]--  , case flagToMaybe (ghcOptHPCDir opts) of-      Nothing -> []-      Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]--  , if parmakeSupported comp-    then case ghcOptNumJobs opts of-      NoFlag  -> []-      Flag n  -> ["-j" ++ maybe "" show n]-    else []--  ---------------------  -- Dynamic linking--  , [ "-shared"  | flagBool ghcOptShared  ]-  , case flagToMaybe (ghcOptDynLinkMode opts) of-      Nothing                  -> []-      Just GhcStaticOnly       -> ["-static"]-      Just GhcDynamicOnly      -> ["-dynamic"]-      Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]-  , [ "-fPIC"    | flagBool ghcOptFPic ]--  , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]--  -------------------------  -- Redirecting outputs--  , concat [ ["-osuf",    suf] | suf <- flag ghcOptObjSuffix ]-  , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]-  , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]-  , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]-  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir-                                 , flagOutputDir implInfo ]-  , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]-  , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]-  , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir-                               , flagStubdir implInfo ]--  ------------------------  -- Source search path--  , [ "-i"        | flagBool ghcOptSourcePathClear ]-  , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]--  ---------------------  -- C and CPP stuff--  , [ "-I"    ++ dir | dir <- flags ghcOptCppIncludePath ]-  , [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]-  , concat [ [ "-optP-include", "-optP" ++ inc]-           | inc <- flags ghcOptCppIncludes ]-  , [ "-#include \"" ++ inc ++ "\""-    | inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ]-  , [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]--  ------------------  -- Linker stuff--  , [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]-  , ["-l" ++ lib     | lib <- flags ghcOptLinkLibs ]-  , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]-  , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]-  , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]-  , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]-  , concat [ [ "-optl-Wl,-rpath," ++ dir]-           | dir <- flags ghcOptRPaths ]--  --------------  -- Packages--  , concat [ [if packageKeySupported comp-                then "-this-package-key"-                else "-package-name", display pkgid]-             | pkgid <- flag ghcOptPackageKey ]--  , [ "-hide-all-packages"     | flagBool ghcOptHideAllPackages ]-  , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]--  , packageDbArgs implInfo (ghcOptPackageDBs opts)--  , if null (ghcOptSigOf opts)-        then []-        else "-sig-of"-             : intercalate "," (map (\(n,(p,m)) -> display n ++ " is "-                                                ++ display p ++ ":"-                                                ++ display m)-                                    (ghcOptSigOf opts))-             : []--  , concat $ if flagPackageId implInfo-      then let space "" = ""-               space xs = ' ' : xs-           in [ ["-package-id", display ipkgid ++ space (display rns)]-              | (ipkgid,_,rns) <- flags ghcOptPackages ]-      else [ ["-package",    display  pkgid]-           | (_,pkgid,_)  <- flags ghcOptPackages ]--  -----------------------------  -- Language and extensions--  , if supportsHaskell2010 implInfo-    then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]-    else []--  , [ case M.lookup ext (ghcOptExtensionMap opts) of-        Just arg -> arg-        Nothing  -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "-                          ++ display ext ++ " not present in ghcOptExtensionMap."-    | ext <- flags ghcOptExtensions ]--  -----------------  -- GHCi--  , concat [ [ "-ghci-script", script ] | script <- flags  ghcOptGHCiScripts-                                        , flagGhciScript implInfo ]--  ----------------  -- Inputs--  , [ display modu | modu <- flags ghcOptInputModules ]-  , flags ghcOptInputFiles--  , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]-  , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]--  ----------------  -- Extra--  , flags ghcOptExtra--  ]---  where-    implInfo     = getImplInfo comp-    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"]---packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]-packageDbArgs implInfo dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-  (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)-                                       : concatMap specific dbs-  _ -> ierror-  where-    specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]-    specific _ = ierror-    ierror     = error $ "internal error: unexpected package db stack: "-                      ++ show dbstack-    packageDbFlag-      | flagPackageConf implInfo-      = "package-conf"-      | otherwise-      = "package-db"----- -------------------------------------------------------------------------------- Boilerplate Monoid instance for GhcOptions--instance Monoid GhcOptions where-  mempty = GhcOptions {-    ghcOptMode               = mempty,-    ghcOptExtra              = mempty,-    ghcOptExtraDefault       = mempty,-    ghcOptInputFiles         = mempty,-    ghcOptInputModules       = mempty,-    ghcOptOutputFile         = mempty,-    ghcOptOutputDynFile      = mempty,-    ghcOptSourcePathClear    = mempty,-    ghcOptSourcePath         = mempty,-    ghcOptPackageKey         = mempty,-    ghcOptPackageDBs         = mempty,-    ghcOptPackages           = mempty,-    ghcOptHideAllPackages    = mempty,-    ghcOptNoAutoLinkPackages = mempty,-    ghcOptSigOf              = mempty,-    ghcOptLinkLibs           = mempty,-    ghcOptLinkLibPath        = mempty,-    ghcOptLinkOptions        = mempty,-    ghcOptLinkFrameworks     = mempty,-    ghcOptNoLink             = mempty,-    ghcOptLinkNoHsMain       = mempty,-    ghcOptCcOptions          = mempty,-    ghcOptCppOptions         = mempty,-    ghcOptCppIncludePath     = mempty,-    ghcOptCppIncludes        = mempty,-    ghcOptFfiIncludes        = mempty,-    ghcOptLanguage           = mempty,-    ghcOptExtensions         = mempty,-    ghcOptExtensionMap       = mempty,-    ghcOptOptimisation       = mempty,-    ghcOptDebugInfo          = mempty,-    ghcOptProfilingMode      = mempty,-    ghcOptSplitObjs          = mempty,-    ghcOptNumJobs            = mempty,-    ghcOptHPCDir             = mempty,-    ghcOptGHCiScripts        = mempty,-    ghcOptHiSuffix           = mempty,-    ghcOptObjSuffix          = mempty,-    ghcOptDynHiSuffix        = mempty,-    ghcOptDynObjSuffix       = mempty,-    ghcOptHiDir              = mempty,-    ghcOptObjDir             = mempty,-    ghcOptOutputDir          = mempty,-    ghcOptStubDir            = mempty,-    ghcOptDynLinkMode        = mempty,-    ghcOptShared             = mempty,-    ghcOptFPic               = mempty,-    ghcOptDylibName          = mempty,-    ghcOptRPaths             = mempty,-    ghcOptVerbosity          = mempty,-    ghcOptCabal              = mempty-  }-  mappend a b = GhcOptions {-    ghcOptMode               = combine ghcOptMode,-    ghcOptExtra              = combine ghcOptExtra,-    ghcOptExtraDefault       = combine ghcOptExtraDefault,-    ghcOptInputFiles         = combine ghcOptInputFiles,-    ghcOptInputModules       = combine ghcOptInputModules,-    ghcOptOutputFile         = combine ghcOptOutputFile,-    ghcOptOutputDynFile      = combine ghcOptOutputDynFile,-    ghcOptSourcePathClear    = combine ghcOptSourcePathClear,-    ghcOptSourcePath         = combine ghcOptSourcePath,-    ghcOptPackageKey         = combine ghcOptPackageKey,-    ghcOptPackageDBs         = combine ghcOptPackageDBs,-    ghcOptPackages           = combine ghcOptPackages,-    ghcOptHideAllPackages    = combine ghcOptHideAllPackages,-    ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,-    ghcOptSigOf              = combine ghcOptSigOf,-    ghcOptLinkLibs           = combine ghcOptLinkLibs,-    ghcOptLinkLibPath        = combine ghcOptLinkLibPath,-    ghcOptLinkOptions        = combine ghcOptLinkOptions,-    ghcOptLinkFrameworks     = combine ghcOptLinkFrameworks,-    ghcOptNoLink             = combine ghcOptNoLink,-    ghcOptLinkNoHsMain       = combine ghcOptLinkNoHsMain,-    ghcOptCcOptions          = combine ghcOptCcOptions,-    ghcOptCppOptions         = combine ghcOptCppOptions,-    ghcOptCppIncludePath     = combine ghcOptCppIncludePath,-    ghcOptCppIncludes        = combine ghcOptCppIncludes,-    ghcOptFfiIncludes        = combine ghcOptFfiIncludes,-    ghcOptLanguage           = combine ghcOptLanguage,-    ghcOptExtensions         = combine ghcOptExtensions,-    ghcOptExtensionMap       = combine ghcOptExtensionMap,-    ghcOptOptimisation       = combine ghcOptOptimisation,-    ghcOptDebugInfo          = combine ghcOptDebugInfo,-    ghcOptProfilingMode      = combine ghcOptProfilingMode,-    ghcOptSplitObjs          = combine ghcOptSplitObjs,-    ghcOptNumJobs            = combine ghcOptNumJobs,-    ghcOptHPCDir             = combine ghcOptHPCDir,-    ghcOptGHCiScripts        = combine ghcOptGHCiScripts,-    ghcOptHiSuffix           = combine ghcOptHiSuffix,-    ghcOptObjSuffix          = combine ghcOptObjSuffix,-    ghcOptDynHiSuffix        = combine ghcOptDynHiSuffix,-    ghcOptDynObjSuffix       = combine ghcOptDynObjSuffix,-    ghcOptHiDir              = combine ghcOptHiDir,-    ghcOptObjDir             = combine ghcOptObjDir,-    ghcOptOutputDir          = combine ghcOptOutputDir,-    ghcOptStubDir            = combine ghcOptStubDir,-    ghcOptDynLinkMode        = combine ghcOptDynLinkMode,-    ghcOptShared             = combine ghcOptShared,-    ghcOptFPic               = combine ghcOptFPic,-    ghcOptDylibName          = combine ghcOptDylibName,-    ghcOptRPaths             = combine ghcOptRPaths,-    ghcOptVerbosity          = combine ghcOptVerbosity,-    ghcOptCabal              = combine ghcOptCabal-  }-    where-      combine field = field a `mappend` field b
− Distribution/Simple/Program/HcPkg.hs 
@@ -1,396 +0,0 @@--------------------------------------------------------------------------------- |--- 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, GHCJS and LHC have hc-pkg programs.--module Distribution.Simple.Program.HcPkg (-    HcPkgInfo(..),--    init,-    invoke,-    register,-    reregister,-    unregister,-    expose,-    hide,-    dump,-    list,--    -- * Program invocations-    initInvocation,-    registerInvocation,-    reregisterInvocation,-    unregisterInvocation,-    exposeInvocation,-    hideInvocation,-    dumpInvocation,-    listInvocation,-  ) where--import Prelude hiding (init)-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) )-import Distribution.Simple.Program.Run-         ( ProgramInvocation(..), IOEncoding(..), programInvocation-         , runProgramInvocation, getProgramInvocationOutput )-import Distribution.Text-         ( display, simpleParse )-import Distribution.Simple.Utils-         ( die )-import Distribution.Verbosity-         ( Verbosity, deafening, silent )-import Distribution.Compat.Exception-         ( catchExit )--import Data.Char-         ( isSpace )-import Data.List-         ( stripPrefix )-import System.FilePath as FilePath-         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )-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-  , useSingleFileDb :: Bool -- ^ requires single file package database-  }---- | Call @hc-pkg@ to initialise a package database at the location {path}.------ > hc-pkg init {path}----init :: HcPkgInfo -> Verbosity -> FilePath -> IO ()-init hpi verbosity path =-  runProgramInvocation verbosity (initInvocation hpi verbosity path)---- | Run @hc-pkg@ using a given package DB stack, directly forwarding the--- provided command-line arguments to it.-invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()-invoke hpi verbosity dbStack extraArgs =-  runProgramInvocation verbosity invocation-  where-    args       = packageDbStackOpts hpi dbStack ++ extraArgs-    invocation = programInvocation (hcPkgProgram hpi) args---- | Call @hc-pkg@ to register a package.------ > hc-pkg register {filename | -} [--user | --global | --package-db]----register :: HcPkgInfo -> Verbosity -> PackageDBStack-         -> Either FilePath-                   InstalledPackageInfo-         -> IO ()-register hpi verbosity packagedb pkgFile =-  runProgramInvocation verbosity-    (registerInvocation hpi verbosity packagedb pkgFile)----- | Call @hc-pkg@ to re-register a package.------ > hc-pkg register {filename | -} [--user | --global | --package-db]----reregister :: HcPkgInfo -> Verbosity -> PackageDBStack-           -> Either FilePath-                     InstalledPackageInfo-           -> IO ()-reregister hpi verbosity packagedb pkgFile =-  runProgramInvocation verbosity-    (reregisterInvocation hpi verbosity packagedb pkgFile)----- | Call @hc-pkg@ to unregister a package------ > hc-pkg unregister [pkgid] [--user | --global | --package-db]----unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-unregister hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (unregisterInvocation hpi verbosity packagedb pkgid)----- | Call @hc-pkg@ to expose a package.------ > hc-pkg expose [pkgid] [--user | --global | --package-db]----expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-expose hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (exposeInvocation hpi verbosity packagedb pkgid)----- | Call @hc-pkg@ to hide a package.------ > hc-pkg hide [pkgid] [--user | --global | --package-db]----hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()-hide hpi verbosity packagedb pkgid =-  runProgramInvocation verbosity-    (hideInvocation hpi verbosity packagedb pkgid)----- | Call @hc-pkg@ to get all the details of all the packages in the given--- package database.----dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]-dump hpi verbosity packagedb = do--  output <- getProgramInvocationOutput verbosity-              (dumpInvocation hpi verbosity packagedb)-    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " dump failed"--  case parsePackages output of-    Left ok -> return ok-    _       -> die $ "failed to parse output of '"-                  ++ programId (hcPkgProgram hpi) ++ " dump'"--  where-    parsePackages str =-      let parsed = map parseInstalledPackageInfo' (splitPkgs str)-       in case [ msg | ParseFailed msg <- parsed ] of-            []   -> Left [   setInstalledPackageId-                           . maybe id mungePackagePaths (pkgRoot pkg)-                           $ pkg-                         | ParseOk _ pkg <- parsed ]-            msgs -> Right msgs--    parseInstalledPackageInfo' =-      parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo--    --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----- | 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 'InstalledPackageId', just--- the source 'PackageId' which is not necessarily unique in any package db.----list :: HcPkgInfo -> Verbosity -> PackageDB-     -> IO [PackageId]-list hpi verbosity packagedb = do--  output <- getProgramInvocationOutput verbosity-              (listInvocation hpi verbosity packagedb)-    `catchExit` \_ -> die $ programId (hcPkgProgram hpi) ++ " list failed"--  case parsePackageIds output of-    Just ok -> return ok-    _       -> die $ "failed to parse output of '"-                  ++ programId (hcPkgProgram hpi) ++ " list'"--  where-    parsePackageIds = sequence . map simpleParse . 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, reregisterInvocation-  :: HcPkgInfo -> Verbosity -> PackageDBStack-  -> Either FilePath InstalledPackageInfo-  -> ProgramInvocation-registerInvocation   = registerInvocation' "register"-reregisterInvocation = registerInvocation' "update"---registerInvocation' :: String -> HcPkgInfo -> Verbosity -> PackageDBStack-                    -> Either FilePath InstalledPackageInfo-                    -> ProgramInvocation-registerInvocation' cmdname hpi verbosity packagedbs (Left pkgFile) =-    programInvocation (hcPkgProgram hpi) args-  where-    args = [cmdname, pkgFile]-        ++ (if noPkgDbStack hpi-              then [packageDbOpts hpi (last packagedbs)]-              else packageDbStackOpts hpi packagedbs)-        ++ verbosityOpts hpi verbosity--registerInvocation' cmdname hpi verbosity packagedbs (Right pkgInfo) =-    (programInvocation (hcPkgProgram hpi) args) {-      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),-      progInvokeInputEncoding = IOEncodingUTF8-    }-  where-    args = [cmdname, "-"]-        ++ (if noPkgDbStack hpi-              then [packageDbOpts hpi (last packagedbs)]-              else packageDbStackOpts hpi packagedbs)-        ++ verbosityOpts hpi verbosity---unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-                     -> ProgramInvocation-unregisterInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["unregister", packageDbOpts hpi packagedb, display pkgid]-    ++ verbosityOpts hpi verbosity---exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-                 -> ProgramInvocation-exposeInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["expose", packageDbOpts hpi packagedb, display pkgid]-    ++ verbosityOpts hpi verbosity---hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId-               -> ProgramInvocation-hideInvocation hpi verbosity packagedb pkgid =-  programInvocation (hcPkgProgram hpi) $-       ["hide", packageDbOpts hpi packagedb, display pkgid]-    ++ verbosityOpts hpi verbosity---dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation-dumpInvocation hpi _verbosity packagedb =-    (programInvocation (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 -> PackageDB -> ProgramInvocation-listInvocation hpi _verbosity packagedb =-    (programInvocation (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 -> PackageDBStack -> [String]-packageDbStackOpts hpi dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"-                                       : "--user"-                                       : map specific dbs-  (GlobalPackageDB:dbs)               -> "--global"-                                       : ("--no-user-" ++ packageDbFlag hpi)-                                       : map specific dbs-  _                                   -> ierror-  where-    specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db-    specific _ = ierror-    ierror :: a-    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)--packageDbFlag :: HcPkgInfo -> String-packageDbFlag hpi-  | flagPackageConf hpi-  = "package-conf"-  | otherwise-  = "package-db"--packageDbOpts :: HcPkgInfo -> PackageDB -> String-packageDbOpts _ GlobalPackageDB        = "--global"-packageDbOpts _ UserPackageDB          = "--user"-packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db--verbosityOpts :: HcPkgInfo -> Verbosity -> [String]-verbosityOpts hpi v-  | noVerboseFlag hpi-                   = []-  | v >= deafening = ["-v2"]-  | v == silent    = ["-v0"]-  | otherwise      = []-
− Distribution/Simple/Program/Hpc.hs 
@@ -1,100 +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.Simple.Utils ( warn )-import Distribution.Verbosity ( Verbosity )-import Distribution.Version ( Version(..), orLaterVersion, withinRange )---- | 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 :: ConfiguredProgram-       -> Version-       -> Verbosity-       -> FilePath            -- ^ Path to .tix file-       -> [FilePath]          -- ^ Paths to .mix file directories-       -> FilePath            -- ^ Path where html output should be located-       -> [ModuleName]        -- ^ List of modules to exclude from report-       -> IO ()-markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do-    hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)-        then return hpcDirs-        else do-            warn verbosity $ "Your version of HPC (" ++ display 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--    runProgramInvocation verbosity-      (markupInvocation hpc tixFile hpcDirs' destDir excluded)-  where-    version07 = Version [0, 7] []-    (passedDirs, droppedDirs) = splitAt 1 hpcDirs--markupInvocation :: ConfiguredProgram-                 -> FilePath            -- ^ Path to .tix file-                 -> [FilePath]          -- ^ Paths to .mix file directories-                 -> FilePath            -- ^ Path where html output should be-                                        -- located-                 -> [ModuleName]        -- ^ List of modules to exclude from-                                        -- report-                 -> ProgramInvocation-markupInvocation hpc tixFile hpcDirs destDir excluded =-    let args = [ "markup", tixFile-               , "--destdir=" ++ destDir-               ]-            ++ map ("--hpcdir=" ++) hpcDirs-            ++ ["--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,257 +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,--    getEffectiveEnvironment,-  ) where--import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..), programPath )-import Distribution.Simple.Utils-         ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut-         , toUTF8, fromUTF8, normaliseLineEndings )-import Distribution.Verbosity-         ( Verbosity )--import Data.List-         ( foldl', unfoldr )-import qualified Data.Map as Map-import Control.Monad-         ( when )-import System.Exit-         ( ExitCode(..), exitWith )-import Distribution.Compat.Environment-         ( getEnvironment )---- | 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 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,-    progInvokeEnv  = programOverrideEnv 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   = envOverrides,-    progInvokeCwd   = mcwd,-    progInvokeInput = Nothing-  } = do-    menv <- getEffectiveEnvironment envOverrides-    exitCode <- rawSystemIOWithEnv verbosity-                                   path args-                                   mcwd menv-                                   Nothing Nothing Nothing-    when (exitCode /= ExitSuccess) $-      exitWith exitCode--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) True-    when (exitCode /= ExitSuccess) $-      die $ "'" ++ path ++ "' exited with an error:\n" ++ errors-  where-    input = case encoding of-              IOEncodingText -> (inputStr, False)-              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for-                                                        -- utf8---getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String-getProgramInvocationOutput verbosity-  ProgramInvocation {-    progInvokePath  = path,-    progInvokeArgs  = args,-    progInvokeEnv   = envOverrides,-    progInvokeCwd   = mcwd,-    progInvokeInput = minputStr,-    progInvokeOutputEncoding = encoding-  } = do-    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False-        decode | utf8      = fromUTF8 . normaliseLineEndings-               | otherwise = id-    menv <- getEffectiveEnvironment envOverrides-    (output, errors, exitCode) <- rawSystemStdInOut verbosity-                                    path args-                                    mcwd menv-                                    input utf8-    when (exitCode /= ExitSuccess) $-      die $ "'" ++ path ++ "' exited with an error:\n" ++ errors-    return (decode output)-  where-    input =-      case minputStr of-        Nothing       -> Nothing-        Just inputStr -> Just $-          case encoding of-            IOEncodingText -> (inputStr, False)-            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8----- | Return the current environment extended with the given overrides.----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 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,110 +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" ]-       ++ concatMap setEnv envExtra-       ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]-       ++ [ (case minput of-              Nothing    -> ""-              Just input -> "echo " ++ quote 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----- | 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 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
− Distribution/Simple/Program/Strip.hs 
@@ -1,72 +0,0 @@--------------------------------------------------------------------------------- |--- 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.Simple.Program (ProgramConfiguration, lookupProgram-                                   , programVersion, rawSystemProgram-                                   , stripProgram)-import Distribution.Simple.Utils   (warn)-import Distribution.System         (Arch(..), Platform(..), OS (..), buildOS)-import Distribution.Verbosity      (Verbosity)-import Distribution.Version        (orLaterVersion, withinRange)--import Control.Monad               (unless)-import Data.Version                (Version(..))-import System.FilePath             (takeBaseName)--runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()-runStrip verbosity progConf path args =-  case lookupProgram stripProgram progConf of-    Just strip -> rawSystemProgram verbosity strip (path: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 or library '"-                                   ++ (takeBaseName path)-                                   ++ "' (missing the 'strip' program)"--stripExe :: Verbosity -> Platform -> ProgramConfiguration -> FilePath -> IO ()-stripExe verbosity (Platform _arch os) conf path =-  runStrip verbosity conf 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 -> ProgramConfiguration -> FilePath -> IO ()-stripLib verbosity (Platform arch os) conf path = do-  case os of-    OSX -> -- '--strip-unneeded' is not supported on OS X, iOS or-           -- Solaris. See #1630.-           return ()-    IOS -> return ()-    Solaris -> return ()-    Windows -> -- Stripping triggers a bug in 'strip.exe' for-               -- libraries with lots identically named modules. See-               -- #1784.-               return()-    Linux | arch == I386 ->-      -- Versions of 'strip' on 32-bit Linux older than 2.18 are-      -- broken. See #2339.-      let okVersion = orLaterVersion (Version [2,18] [])-      in case programVersion =<< lookupProgram stripProgram conf of-          Just v | withinRange v okVersion ->-            runStrip verbosity conf path args-          _ -> warn verbosity $ "Unable to strip library '"-                                ++ (takeBaseName path)-                                ++ "' (version of 'strip' too old; "-                                ++ "requires >= 2.18 on 32-bit Linux)"-    _   -> runStrip verbosity conf path args-  where-    args = ["--strip-unneeded"]
− Distribution/Simple/Program/Types.hs 
@@ -1,164 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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(..),-    simpleProgram,--    -- * Configured program and related functions-    ConfiguredProgram(..),-    programPath,-    suppressOverrideArgs,-    ProgArg,-    ProgramLocation(..),-    simpleConfiguredProgram,-  ) where--import Distribution.Simple.Program.Find-         ( ProgramSearchPath, ProgramSearchPathEntry(..)-         , findProgramOnSearchPath )-import Distribution.Version-         ( Version )-import Distribution.Verbosity-         ( Verbosity )--import Distribution.Compat.Binary (Binary)-import qualified Data.Map as Map-import GHC.Generics (Generic)---- | 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 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.-       programFindLocation :: Verbosity -> ProgramSearchPath-                              -> 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). For example-       -- it could add args, or environment vars.-       programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram-     }--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],--       -- | Override environment variables for this program.-       -- These env vars will extend\/override the prevailing environment of-       -- the current to form the environment for the new process.-       programOverrideEnv :: [(String, Maybe String)],--       -- | A key-value map listing various properties of the program, useful-       -- for feature detection. Populated during the configuration step, key-       -- names depend on the specific program.-       programProperties :: Map.Map String String,--       -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@-       programLocation :: ProgramLocation-     } deriving (Eq, Generic, Read, Show)--instance Binary ConfiguredProgram---- | Where a program was found. Also tells us whether it's specified by user or--- not.  This includes not just the path, but the program as well.-data ProgramLocation-    = UserSpecified { locationPath :: FilePath }-      -- ^The user gave the path to this program,-      -- eg. --ghc-path=\/usr\/bin\/ghc-6.6-    | FoundOnSystem { locationPath :: FilePath }-      -- ^The program was found automatically.-      deriving (Eq, Generic, Read, Show)--instance Binary 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 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-  }---- | 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-  }
− Distribution/Simple/Register.hs 
@@ -1,464 +0,0 @@--------------------------------------------------------------------------------- |--- 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 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,--    initPackageDB,-    invokeHcPkg,-    registerPackage,-    generateRegistrationInfo,-    inplaceInstalledPackageInfo,-    absoluteInstalledPackageInfo,-    generalInstalledPackageInfo,-  ) where--import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , ComponentName(..), getComponentLocalBuildInfo-         , LibraryName(..)-         , InstallDirs(..), absoluteInstallDirs )-import Distribution.Simple.BuildPaths (haddockName)--import qualified Distribution.Simple.GHC   as GHC-import qualified Distribution.Simple.GHCJS as GHCJS-import qualified Distribution.Simple.LHC   as LHC-import qualified Distribution.Simple.UHC   as UHC-import qualified Distribution.Simple.HaskellSuite as HaskellSuite--import Distribution.Simple.Compiler-         ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor-         , PackageDB, PackageDBStack, absolutePackageDBPaths-         , registrationPackageDB )-import Distribution.Simple.Program-         ( ProgramConfiguration, runProgramInvocation )-import Distribution.Simple.Program.Script-         ( invocationAsSystemScript )-import           Distribution.Simple.Program.HcPkg (HcPkgInfo)-import qualified Distribution.Simple.Program.HcPkg as HcPkg-import Distribution.Simple.Setup-         ( RegisterFlags(..), CopyDest(..)-         , fromFlag, fromFlagOrDefault, flagToMaybe )-import Distribution.PackageDescription-         ( PackageDescription(..), Library(..), BuildInfo(..), libModules )-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, shortRelativePath )-import Distribution.System-         ( OS(..), buildOS )-import Distribution.Text-         ( display )-import Distribution.Version ( Version(..) )-import Distribution.Verbosity as Verbosity-         ( Verbosity, normal )--import System.FilePath ((</>), (<.>), isAbsolute)-import System.Directory-         ( getCurrentDirectory )--import Control.Monad (when)-import Data.Maybe-         ( isJust, fromMaybe, maybeToList )-import Data.List-         ( partition, nub )-import qualified Data.ByteString.Lazy.Char8 as BS.Char8---- -------------------------------------------------------------------------------- Registration--register :: PackageDescription -> LocalBuildInfo-         -> RegisterFlags -- ^Install in the user's database?; verbose-         -> IO ()-register pkg@PackageDescription { library       = Just lib  } lbi regFlags-  = do-    let clbi = getComponentLocalBuildInfo lbi CLibName--    absPackageDBs    <- absolutePackageDBPaths packageDbs-    installedPkgInfo <- generateRegistrationInfo-                           verbosity pkg lib lbi clbi inplace reloc distPref-                           (registrationPackageDB absPackageDBs)--    when (fromFlag (regPrintId regFlags)) $ do-      putStrLn (display (IPI.installedPackageId installedPkgInfo))--     -- 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)-    reloc     = relocatable lbi-    -- FIXME: there's really no guarantee this will work.-    -- registering into a totally different db stack can-    -- fail if dependencies cannot be satisfied.-    packageDbs = nub $ withPackageDB lbi-                    ++ maybeToList (flagToMaybe  (regPackageDB regFlags))-    distPref  = fromFlag (regDistPref regFlags)-    verbosity = fromFlag (regVerbosity regFlags)--    writeRegistrationFile installedPkgInfo = do-      notice verbosity ("Creating package registration file: " ++ regFile)-      writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo)--    writeRegisterScript installedPkgInfo =-      case compilerFlavor (compiler lbi) of-        JHC -> notice verbosity "Registration scripts not needed for jhc"-        UHC -> notice verbosity "Registration scripts not needed for uhc"-        _   -> withHcPkg-               "Registration scripts are not implemented for this compiler"-               (compiler lbi) (withPrograms lbi)-               (writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs)--register _ _ regFlags = notice verbosity "No package to register"-  where-    verbosity = fromFlag (regVerbosity regFlags)---generateRegistrationInfo :: Verbosity-                         -> PackageDescription-                         -> Library-                         -> LocalBuildInfo-                         -> ComponentLocalBuildInfo-                         -> Bool-                         -> Bool-                         -> FilePath-                         -> PackageDB-                         -> IO InstalledPackageInfo-generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do-  --TODO: eliminate pwd!-  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))-     GHCJS -> do-            s <- GHCJS.libAbiHash verbosity pkg lbi lib clbi-            return (InstalledPackageId (display (packageId pkg) ++ '-':s))-     _other -> do-            return (InstalledPackageId (display (packageId pkg)))--  installedPkgInfo <--    if inplace-      then return (inplaceInstalledPackageInfo pwd distPref-                     pkg ipid lib lbi clbi)-    else if reloc-      then relocRegistrationInfo verbosity-                     pkg lib lbi clbi ipid packageDb-      else return (absoluteInstalledPackageInfo-                     pkg ipid lib lbi clbi)---  return installedPkgInfo{ IPI.installedPackageId = ipid }--relocRegistrationInfo :: Verbosity-                      -> PackageDescription-                      -> Library-                      -> LocalBuildInfo-                      -> ComponentLocalBuildInfo-                      -> InstalledPackageId-                      -> PackageDB-                      -> IO InstalledPackageInfo-relocRegistrationInfo verbosity pkg lib lbi clbi ipid packageDb =-  case (compilerFlavor (compiler lbi)) of-    GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb-              return (relocatableInstalledPackageInfo-                        pkg ipid lib lbi clbi fs)-    _   -> die "Distribution.Simple.Register.relocRegistrationInfo: \-               \not implemented for this compiler"---- | Create an empty package DB at the specified location.-initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath-                 -> IO ()-initPackageDB verbosity comp conf dbPath =-  case compilerFlavor comp of-    HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath-    _               -> withHcPkg "Distribution.Simple.Register.initPackageDB: \-                                 \not implemented for this compiler" comp conf-                                 (\hpi -> HcPkg.init hpi verbosity dbPath)---- | Run @hc-pkg@ using a given package DB stack, directly forwarding the--- provided command-line arguments to it.-invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack-                -> [String] -> IO ()-invokeHcPkg verbosity comp conf dbStack extraArgs =-  withHcPkg "invokeHcPkg" comp conf-    (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)--withHcPkg :: String -> Compiler -> ProgramConfiguration-          -> (HcPkgInfo -> IO a) -> IO a-withHcPkg name comp conf f =-  case compilerFlavor comp of-    GHC   -> f (GHC.hcPkgInfo conf)-    GHCJS -> f (GHCJS.hcPkgInfo conf)-    LHC   -> f (LHC.hcPkgInfo conf)-    _     -> die ("Distribution.Simple.Register." ++ name ++ ":\-                  \not implemented for this compiler")--registerPackage :: Verbosity-                -> InstalledPackageInfo-                -> PackageDescription-                -> LocalBuildInfo-                -> Bool-                -> PackageDBStack-                -> IO ()-registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do-  let msg = if inplace-            then "In-place registering"-            else "Registering"-  setupMessage verbosity msg (packageId pkg)-  case compilerFlavor (compiler lbi) of-    GHC   -> GHC.registerPackage   verbosity installedPkgInfo pkg lbi inplace packageDbs-    GHCJS -> GHCJS.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs-    LHC   -> LHC.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)"-    HaskellSuite {} ->-      HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs-    _    -> die "Registering is not implemented for this compiler"--writeHcPkgRegisterScript :: Verbosity-                         -> InstalledPackageInfo-                         -> PackageDBStack-                         -> HcPkgInfo-                         -> IO ()-writeHcPkgRegisterScript verbosity installedPkgInfo packageDbs hpi = do-  let invocation  = HcPkg.reregisterInvocation hpi 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-  -> InstalledPackageId-  -> Library-  -> LocalBuildInfo-  -> ComponentLocalBuildInfo-  -> InstallDirs FilePath-  -> InstalledPackageInfo-generalInstalledPackageInfo adjustRelIncDirs pkg ipid lib lbi clbi installDirs =-  InstalledPackageInfo {-    IPI.installedPackageId = ipid,-    IPI.sourcePackageId    = packageId   pkg,-    IPI.packageKey         = pkgKey lbi,-    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     = map fixupSelf (componentExposedModules clbi),-    IPI.hiddenModules      = otherModules bi,-    IPI.instantiatedWith   = map (\(k,(p,n)) ->-                                   (k,IPI.OriginalModule (IPI.installedPackageId p) n))-                                 (instantiatedWith lbi),-    IPI.trusted            = IPI.trusted IPI.emptyInstalledPackageInfo,-    IPI.importDirs         = [ libdir installDirs | hasModules ],-    -- Note. the libsubdir and datasubdir templates have already been expanded-    -- into libdir and datadir.-    IPI.libraryDirs        = if hasLibrary-                               then libdir installDirs : extraLibDirs bi-                               else                      extraLibDirs bi,-    IPI.dataDir            = datadir installDirs,-    IPI.hsLibraries        = [ libname-                             | LibraryName libname <- componentLibraries clbi-                             , hasLibrary ],-    IPI.extraLibraries     = extraLibs bi,-    IPI.extraGHCiLibraries = extraGHCiLibs bi,-    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,-    IPI.includes           = includes bi,-    IPI.depends            = map fst (componentPackageDeps clbi),-    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],-    IPI.pkgRoot            = Nothing-  }-  where-    bi = libBuildInfo lib-    (absinc, relinc) = partition isAbsolute (includeDirs bi)-    hasModules = not $ null (libModules lib)-    hasLibrary = hasModules || not (null (cSources bi))-                            || (not (null (jsSources bi)) &&-                                compilerFlavor (compiler lbi) == GHCJS)--    -- Since we currently don't decide the InstalledPackageId of our package-    -- until just before we register, we didn't have one for the re-exports-    -- of modules defined within this package, so we used an empty one that-    -- we fill in here now that we know what it is. It's a bit of a hack,-    -- we ought really to decide the InstalledPackageId ahead of time.-    fixupSelf (IPI.ExposedModule n o o') =-        IPI.ExposedModule n (fmap fixupOriginalModule o)-                            (fmap fixupOriginalModule o')-    fixupOriginalModule (IPI.OriginalModule i m) = IPI.OriginalModule (fixupIpid i) m-    fixupIpid (InstalledPackageId []) = ipid-    fixupIpid x = x---- | Construct 'InstalledPackageInfo' for a library that is in place in the--- build tree.------ This function knows about the layout of in place packages.----inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree-                            -> FilePath -- ^ location of the dist tree-                            -> PackageDescription-                            -> InstalledPackageId-                            -> Library-                            -> LocalBuildInfo-                            -> ComponentLocalBuildInfo-                            -> InstalledPackageInfo-inplaceInstalledPackageInfo inplaceDir distPref pkg ipid lib lbi clbi =-    generalInstalledPackageInfo adjustRelativeIncludeDirs-                                pkg ipid lib lbi clbi installDirs-  where-    adjustRelativeIncludeDirs = map (inplaceDir </>)-    installDirs =-      (absoluteInstallDirs pkg lbi NoCopyDest) {-        libdir     = inplaceDir </> buildDir lbi,-        datadir    = inplaceDir </> dataDir pkg,-        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-                             -> InstalledPackageId-                             -> Library-                             -> LocalBuildInfo-                             -> ComponentLocalBuildInfo-                             -> InstalledPackageInfo-absoluteInstalledPackageInfo pkg ipid lib lbi clbi =-    generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg ipid 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 = absoluteInstallDirs pkg lbi NoCopyDest---relocatableInstalledPackageInfo :: PackageDescription-                                -> InstalledPackageId-                                -> Library-                                -> LocalBuildInfo-                                -> ComponentLocalBuildInfo-                                -> FilePath-                                -> InstalledPackageInfo-relocatableInstalledPackageInfo pkg ipid lib lbi clbi pkgroot =-    generalInstalledPackageInfo adjustReativeIncludeDirs-                                pkg ipid 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 pkgroot)-                $ 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)-      unreg hpi =-        let invocation = HcPkg.unregisterInvocation-                           hpi Verbosity.normal packageDb pkgid-        in if genScript-             then writeFileAtomic unregScriptFileName-                    (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)-             else runProgramInvocation verbosity invocation-  setupMessage verbosity "Unregistering" pkgid-  withHcPkg "unregistering is only implemented for GHC and GHCJS"-    (compiler lbi) (withPrograms lbi) unreg--unregScriptFileName :: FilePath-unregScriptFileName = case buildOS of-                          Windows -> "unregister.bat"-                          _       -> "unregister.sh"
− Distribution/Simple/Setup.hs 
@@ -1,2223 +0,0 @@-{-# LANGUAGE CPP           #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Setup--- Copyright   :  Isaac Jones 2003-2004---                Duncan Coutts 2007--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ This is a big module, but not very complicated. The code is very regular--- and repetitive. It defines the command line interface for all the Cabal--- commands. For each command (like @configure@, @build@ etc) it defines a type--- that holds all the flags, the default set of flags and a 'CommandUI' that--- maps command line flags to and from the corresponding flags type.------ All the flags types are instances of 'Monoid', see--- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>--- for an explanation.------ The types defined here get used in the front end and especially in--- @cabal-install@ which has to do quite a bit of manipulating sets of command--- line flags.------ This is actually relatively nice, it works quite well. The main change it--- needs is to unify it with the code for managing sets of fields that can be--- read and written from files. This would allow us to save configure flags in--- config files.--{-# LANGUAGE CPP #-}--module Distribution.Simple.Setup (--  GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,-  ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,-  configAbsolutePaths, readPackageDbList, showPackageDbList,-  CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,-  InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,-  HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,-  HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,-  BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,-  buildVerbose,-  ReplFlags(..),                         defaultReplFlags,     replCommand,-  CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,-  RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,-                                                               unregisterCommand,-  SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,-  TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,-  TestShowDetails(..),-  BenchmarkFlags(..), emptyBenchmarkFlags,-  defaultBenchmarkFlags, benchmarkCommand,-  CopyDest(..),-  configureArgs, configureOptions, configureCCompiler, configureLinker,-  buildOptions, haddockOptions, installDirsOptions,-  programConfigurationOptions, programConfigurationPaths',--  defaultDistPref,--  Flag(..),-  toFlag,-  fromFlag,-  fromFlagOrDefault,-  flagToMaybe,-  flagToList,-  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) 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.ModuleName-import Distribution.Package ( Dependency(..)-                            , PackageName-                            , InstalledPackageId )-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(..)-         , DebugInfoLevel(..), flagToDebugInfoLevel-         , OptimisationLevel(..), flagToOptimisationLevel-         , absolutePackageDBPath )-import Distribution.Simple.Utils-         ( wrapText, 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 Distribution.Utils.NubList--import Control.Monad (liftM)-import Distribution.Compat.Binary (Binary)-import Data.List   ( sort )-import Data.Char   ( isSpace, isAlpha )-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid ( Monoid(..) )-#endif-import GHC.Generics (Generic)---- 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 (Eq, Generic, Show, Read)--instance Binary a => Binary (Flag a)--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   = []--allFlags :: [Flag Bool] -> Flag Bool-allFlags flags = if all (\f -> fromFlagOrDefault False f) flags-                 then Flag True-                 else 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 :: [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 ++ "    " ++ description-                 | (name, description) <- cmdDescs ]-      ++ "\n"-      ++ "For more information about a command use\n"-      ++ "  " ++ pname ++ " COMMAND --help\n\n"-      ++ "Typical steps for installing Cabal packages:\n"-      ++ concat [ "  " ++ pname ++ " " ++ x ++ "\n"-                | x <- ["configure", "build", "install"]]-  , commandNotes        = Nothing-  , commandDefaultFlags = defaultGlobalFlags-  , commandOptions      = \_ ->-      [option ['V'] ["version"]-         "Print version information"-         globalVersion (\v flags -> flags { globalVersion = v })-         trueArg-      ,option [] ["numeric-version"]-         "Print just the version number"-         globalNumericVersion (\v flags -> flags { globalNumericVersion = v })-         trueArg-      ]-  }--emptyGlobalFlags :: GlobalFlags-emptyGlobalFlags = mempty--instance Monoid GlobalFlags where-  mempty = 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.------ IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'--- should be updated.-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 specified programs paths-    configProgramArgs   :: [(String, [String])], -- ^user specified programs args-    configProgramPathExtra :: NubList FilePath,  -- ^Extend the $PATH-    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the-                                                -- compiler, such as GHC or-                                                -- JHC.-    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-    configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use-    configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi-    configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC-    configStripExes :: Flag Bool,      -- ^Enable executable stripping-    configStripLibs :: Flag Bool,      -- ^Enable library stripping-    configConstraints :: [Dependency], -- ^Additional constraints for-                                       -- dependencies.-    configDependencies :: [(PackageName, InstalledPackageId)],-    configInstantiateWith :: [(ModuleName, (InstalledPackageId, ModuleName))],-      -- ^The packages depended on.-    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.-  }-  deriving (Generic, Read, Show)--instance Binary ConfigFlags--configAbsolutePaths :: ConfigFlags -> IO ConfigFlags-configAbsolutePaths f =-  (\v -> f { configPackageDBs = v })-  `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))-  (configPackageDBs f)--defaultConfigFlags :: ProgramConfiguration -> ConfigFlags-defaultConfigFlags progConf = emptyConfigFlags {-    configPrograms     = progConf,-    configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,-    configVanillaLib   = Flag True,-    configProfLib      = NoFlag,-    configSharedLib    = NoFlag,-    configDynExe       = Flag False,-    configProfExe      = NoFlag,-    configOptimization = Flag NormalOptimisation,-    configProgPrefix   = Flag (toPathTemplate ""),-    configProgSuffix   = Flag (toPathTemplate ""),-    configDistPref     = Flag defaultDistPref,-    configVerbosity    = Flag normal,-    configUserInstall  = Flag False,           --TODO: reverse this-#if defined(mingw32_HOST_OS)-    -- See #1589.-    configGHCiLib      = Flag True,-#else-    configGHCiLib      = NoFlag,-#endif-    configSplitObjs    = Flag False, -- takes longer, so turn off by default-    configStripExes    = Flag True,-    configStripLibs    = Flag True,-    configTests        = Flag False,-    configBenchmarks   = Flag False,-    configCoverage     = Flag False,-    configLibCoverage  = NoFlag,-    configExactConfiguration = Flag False,-    configFlagError    = NoFlag,-    configRelocatable  = Flag False,-    configDebugInfo    = Flag NoDebugInfo-  }--configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = 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 (\_ -> programFlagsDescription progConf)-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " configure [FLAGS]\n"-  , commandDefaultFlags = defaultConfigFlags progConf-  , commandOptions      = \showOrParseArgs ->-         configureOptions showOrParseArgs-      ++ programConfigurationPaths   progConf showOrParseArgs-           configProgramPaths (\v fs -> fs { configProgramPaths = v })-      ++ programConfigurationOption progConf showOrParseArgs-           configProgramArgs (\v fs -> fs { configProgramArgs = 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 GHCJS, ([] , ["ghcjs"]), "compile with GHCJS")-                    , (Flag JHC,   ([] , ["jhc"]),   "compile with JHC")-                    , (Flag LHC,   ([] , ["lhc"]),   "compile with LHC")-                    , (Flag UHC,   ([] , ["uhc"]),   "compile with UHC")-                    -- "haskell-suite" compiler id string will be replaced-                    -- by a more specific one during the configure stage-                    , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),-                        "compile with a haskell-suite compiler")])--      ,option "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 "" ["executable-dynamic"]-         "Executable dynamic linking"-         configDynExe (\v flags -> flags { configDynExe = v })-         (boolOpt [] [])--      ,option "" ["profiling"]-         "Executable profiling (requires library profiling)"-         -- HACK: See #2409. Thankfully, this is 1.22-specific.-         (\flags ->-           case (configProfLib flags, configProfExe flags) of-             (Flag a, Flag b)-               | (a == b)-               && ("cabalConfProf", "/TRUE") `elem` configProgramPaths flags-                    -> configProfExe flags-             _      -> NoFlag)-         (\v flags -> flags-               { configProfLib = v, configProfExe = v-               , configProgramPaths = ("cabalConfProf", "/TRUE")-               : configProgramPaths flags })-         (boolOpt [] [])--      ,option "" ["executable-profiling"]-         "Executable profiling (DEPRECATED)"-         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"-         ]--      ,multiOption "debug-info"-         configDebugInfo (\v flags -> flags { configDebugInfo = v })-         [optArg' "n" (Flag . flagToDebugInfoLevel)-                     (\f -> case f of-                              Flag NoDebugInfo      -> []-                              Flag MinimalDebugInfo -> [Just "1"]-                              Flag NormalDebugInfo  -> [Nothing]-                              Flag MaximalDebugInfo -> [Just "3"]-                              _                     -> [])-                 "" ["enable-debug-info"]-                 "Emit debug info (n is 0--3, default is 0)",-          noArg (Flag NoDebugInfo) []-                ["disable-debug-info"]-                "Don't emit debug info"-         ]--      ,option "" ["library-for-ghci"]-         "compile library for use with GHCi"-         configGHCiLib (\v flags -> flags { configGHCiLib = v })-         (boolOpt [] [])--      ,option "" ["split-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"]-         "Use a given package database (to satisfy dependencies and register in). May be a specific file, 'global', 'user' or 'clear'."-         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" 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 "" ["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"-                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))-                 (map (\x -> display x)))--      ,option "" ["dependency"]-         "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""-         configDependencies (\v flags -> flags { configDependencies = v})-         (reqArg "NAME=ID"-                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))-                 (map (\x -> display (fst x) ++ "=" ++ display (snd x))))--      ,option "" ["instantiate-with"]-         "A mapping of signature names to concrete module instantiations. E.g., --instantiate-with=\"Map=Data.Map.Strict@containers-0.5.5.1-inplace\""-         configInstantiateWith (\v flags -> flags { configInstantiateWith = v })-         (reqArg "NAME=PKG:MOD"-                 (readP_to_E (const "signature mapping expected") ((\x -> [x]) `fmap` parseHoleMapEntry))-                 (map (\(n,(p,m)) -> display n ++ "=" ++ display m ++ "@" ++ display p)))--      ,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 [] [])-      ]-  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)--readPackageDbList :: String -> [Maybe PackageDB]-readPackageDbList "clear"  = [Nothing]-readPackageDbList "global" = [Just GlobalPackageDB]-readPackageDbList "user"   = [Just UserPackageDB]-readPackageDbList other    = [Just (SpecificPackageDB other)]--showPackageDbList :: [Maybe PackageDB] -> [String]-showPackageDbList = map showPackageDb-  where-    showPackageDb Nothing                       = "clear"-    showPackageDb (Just GlobalPackageDB)        = "global"-    showPackageDb (Just UserPackageDB)          = "user"-    showPackageDb (Just (SpecificPackageDB db)) = db---parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)-parseDependency = do-  x <- parse-  _ <- Parse.char '='-  y <- parse-  return (x, y)--parseHoleMapEntry :: Parse.ReadP r (ModuleName, (InstalledPackageId, ModuleName))-parseHoleMapEntry = do-  x <- parse-  _ <- Parse.char '='-  y <- parse-  _ <- Parse.char '@'-  z <- parse-  return (x, (z, y))--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--  , 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 = ConfigFlags {-    configPrograms      = error "FIXME: remove configPrograms",-    configProgramPaths  = mempty,-    configProgramArgs   = mempty,-    configProgramPathExtra = 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,-    configPackageDBs    = mempty,-    configGHCiLib       = mempty,-    configSplitObjs     = mempty,-    configStripExes     = mempty,-    configStripLibs     = mempty,-    configExtraLibDirs  = mempty,-    configConstraints   = mempty,-    configDependencies  = mempty,-    configInstantiateWith     = mempty,-    configExtraIncludeDirs    = mempty,-    configConfigurationsFlags = mempty,-    configTests               = mempty,-    configCoverage         = mempty,-    configLibCoverage   = mempty,-    configExactConfiguration  = mempty,-    configBenchmarks          = mempty,-    configFlagError     = mempty,-    configRelocatable   = mempty,-    configDebugInfo     = mempty-  }-  mappend a b =  ConfigFlags {-    configPrograms      = configPrograms b,-    configProgramPaths  = combine configProgramPaths,-    configProgramArgs   = combine configProgramArgs,-    configProgramPathExtra = combine configProgramPathExtra,-    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,-    configPackageDBs    = combine configPackageDBs,-    configGHCiLib       = combine configGHCiLib,-    configSplitObjs     = combine configSplitObjs,-    configStripExes     = combine configStripExes,-    configStripLibs     = combine configStripLibs,-    configExtraLibDirs  = combine configExtraLibDirs,-    configConstraints   = combine configConstraints,-    configDependencies  = combine configDependencies,-    configInstantiateWith     = combine configInstantiateWith,-    configExtraIncludeDirs    = combine configExtraIncludeDirs,-    configConfigurationsFlags = combine configConfigurationsFlags,-    configTests               = combine configTests,-    configCoverage         = combine configCoverage,-    configLibCoverage         = combine configLibCoverage,-    configExactConfiguration  = combine configExactConfiguration,-    configBenchmarks          = combine configBenchmarks,-    configFlagError     = combine configFlagError,-    configRelocatable   = combine configRelocatable,-    configDebugInfo     = combine configDebugInfo-  }-    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 = CommandUI-  { commandName         = "copy"-  , commandSynopsis     = "Copy the files into the install locations."-  , commandDescription  = Just $ \_ -> wrapText $-          "Does not call register, and allows a prefix at install time. "-       ++ "Without the --destdir flag, configure determines location.\n"-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " copy [FLAGS]\n"-  , commandDefaultFlags = defaultCopyFlags-  , commandOptions      = \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 = 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 ->-      [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,-    sDistListSources :: Flag FilePath,-    sDistVerbosity   :: Flag Verbosity-  }-  deriving Show--defaultSDistFlags :: SDistFlags-defaultSDistFlags = SDistFlags {-    sDistSnapshot    = Flag False,-    sDistDirectory   = mempty,-    sDistDistPref    = Flag defaultDistPref,-    sDistListSources = mempty,-    sDistVerbosity   = Flag normal-  }--sdistCommand :: CommandUI SDistFlags-sdistCommand = CommandUI-  { commandName         = "sdist"-  , commandSynopsis     =-      "Generate a source distribution file (.tar.gz)."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " sdist [FLAGS]\n"-  , commandDefaultFlags = defaultSDistFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })-      ,optionDistPref-         sDistDistPref (\d flags -> flags { sDistDistPref = d })-         showOrParseArgs--      ,option "" ["list-sources"]-         "Just write a list of the package's sources to a file"-         sDistListSources (\v flags -> flags { sDistListSources = v })-         (reqArgFlag "FILE")--      ,option "" ["snapshot"]-         "Produce a snapshot source distribution"-         sDistSnapshot (\v flags -> flags { sDistSnapshot = v })-         trueArg--      ,option "" ["output-directory"]-       ("Generate a source distribution in the given directory, "-        ++ "without creating a tarball")-         sDistDirectory (\v flags -> flags { sDistDirectory = v })-         (reqArgFlag "DIR")-      ]-  }--emptySDistFlags :: SDistFlags-emptySDistFlags = mempty--instance Monoid SDistFlags where-  mempty = SDistFlags {-    sDistSnapshot    = mempty,-    sDistDirectory   = mempty,-    sDistDistPref    = mempty,-    sDistListSources = mempty,-    sDistVerbosity   = mempty-  }-  mappend a b = SDistFlags {-    sDistSnapshot    = combine sDistSnapshot,-    sDistDirectory   = combine sDistDirectory,-    sDistDistPref    = combine sDistDistPref,-    sDistListSources = combine sDistListSources,-    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,-    regPrintId     :: Flag Bool,-    regVerbosity   :: Flag Verbosity-  }-  deriving Show--defaultRegisterFlags :: RegisterFlags-defaultRegisterFlags = RegisterFlags {-    regPackageDB   = NoFlag,-    regGenScript   = Flag False,-    regGenPkgConf  = NoFlag,-    regInPlace     = Flag False,-    regDistPref    = Flag defaultDistPref,-    regPrintId     = Flag False,-    regVerbosity   = Flag normal-  }--registerCommand :: CommandUI RegisterFlags-registerCommand = CommandUI-  { commandName         = "register"-  , commandSynopsis     =-      "Register this package with the compiler."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " register [FLAGS]\n"-  , commandDefaultFlags = defaultRegisterFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })-      ,optionDistPref-         regDistPref (\d flags -> flags { regDistPref = d })-         showOrParseArgs--      ,option "" ["packageDB"] ""-         regPackageDB (\v flags -> flags { regPackageDB = v })-         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),-                                "upon registration, register this package in the user's local package database")-                    , (Flag GlobalPackageDB, ([],["global"]),-                                "(default)upon registration, register this package in the system-wide package database")])--      ,option "" ["inplace"]-         "register the package in the build location, so it can be used without being installed"-         regInPlace (\v flags -> flags { regInPlace = v })-         trueArg--      ,option "" ["gen-script"]-         "instead of registering, generate a script to register later"-         regGenScript (\v flags -> flags { regGenScript = v })-         trueArg--      ,option "" ["gen-pkg-config"]-         "instead of registering, generate a package registration file"-         regGenPkgConf (\v flags -> flags { regGenPkgConf  = v })-         (optArg' "PKG" Flag flagToList)--      ,option "" ["print-ipid"]-         "print the installed package ID calculated for this package"-         regPrintId (\v flags -> flags { regPrintId = v })-         trueArg-      ]-  }--unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = CommandUI-  { commandName         = "unregister"-  , commandSynopsis     =-      "Unregister this package with the compiler."-  , commandDescription  = Nothing-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " unregister [FLAGS]\n"-  , commandDefaultFlags = defaultRegisterFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })-      ,optionDistPref-         regDistPref (\d flags -> flags { regDistPref = d })-          showOrParseArgs--      ,option "" ["user"] ""-         regPackageDB (\v flags -> flags { regPackageDB = v })-         (choiceOpt [ (Flag UserPackageDB, ([],["user"]),-                              "unregister this package in the user's local package database")-                    , (Flag GlobalPackageDB, ([],["global"]),-                              "(default) unregister this package in the  system-wide package database")])--      ,option "" ["gen-script"]-         "Instead of performing the unregister command, generate a script to unregister later"-         regGenScript (\v flags -> flags { regGenScript = v })-         trueArg-      ]-  }--emptyRegisterFlags :: RegisterFlags-emptyRegisterFlags = mempty--instance Monoid RegisterFlags where-  mempty = RegisterFlags {-    regPackageDB   = mempty,-    regGenScript   = mempty,-    regGenPkgConf  = mempty,-    regInPlace     = mempty,-    regPrintId     = mempty,-    regDistPref    = mempty,-    regVerbosity   = mempty-  }-  mappend a b = RegisterFlags {-    regPackageDB   = combine regPackageDB,-    regGenScript   = combine regGenScript,-    regGenPkgConf  = combine regGenPkgConf,-    regInPlace     = combine regInPlace,-    regPrintId     = combine regPrintId,-    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,-    hscolourTestSuites  :: Flag Bool,-    hscolourBenchmarks  :: Flag Bool,-    hscolourDistPref    :: Flag FilePath,-    hscolourVerbosity   :: Flag Verbosity-  }-  deriving Show--emptyHscolourFlags :: HscolourFlags-emptyHscolourFlags = mempty--defaultHscolourFlags :: HscolourFlags-defaultHscolourFlags = HscolourFlags {-    hscolourCSS         = NoFlag,-    hscolourExecutables = Flag False,-    hscolourTestSuites  = Flag False,-    hscolourBenchmarks  = Flag False,-    hscolourDistPref    = Flag defaultDistPref,-    hscolourVerbosity   = Flag normal-  }--instance Monoid HscolourFlags where-  mempty = HscolourFlags {-    hscolourCSS         = mempty,-    hscolourExecutables = mempty,-    hscolourTestSuites  = mempty,-    hscolourBenchmarks  = mempty,-    hscolourDistPref    = mempty,-    hscolourVerbosity   = mempty-  }-  mappend a b = HscolourFlags {-    hscolourCSS         = combine hscolourCSS,-    hscolourExecutables = combine hscolourExecutables,-    hscolourTestSuites  = combine hscolourTestSuites,-    hscolourBenchmarks  = combine hscolourBenchmarks,-    hscolourDistPref    = combine hscolourDistPref,-    hscolourVerbosity   = combine hscolourVerbosity-  }-    where combine field = field a `mappend` field b--hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = CommandUI-  { commandName         = "hscolour"-  , commandSynopsis     =-      "Generate HsColour colourised code, in HTML format."-  , commandDescription  = Just (\_ -> "Requires the hscolour program.\n")-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " hscolour [FLAGS]\n"-  , commandDefaultFlags = defaultHscolourFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity hscolourVerbosity-       (\v flags -> flags { hscolourVerbosity = v })-      ,optionDistPref-         hscolourDistPref (\d flags -> flags { hscolourDistPref = d })-         showOrParseArgs--      ,option "" ["executables"]-         "Run hscolour for Executables targets"-         hscolourExecutables (\v flags -> flags { hscolourExecutables = v })-         trueArg--      ,option "" ["tests"]-         "Run hscolour for Test Suite targets"-         hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })-         trueArg--      ,option "" ["benchmarks"]-         "Run hscolour for Benchmark targets"-         hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })-         trueArg--      ,option "" ["all"]-         "Run hscolour for all targets"-         (\f -> allFlags [ hscolourExecutables f-                         , hscolourTestSuites  f-                         , hscolourBenchmarks  f])-         (\v flags -> flags { hscolourExecutables = v-                            , hscolourTestSuites  = v-                            , hscolourBenchmarks  = 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,-    haddockTestSuites   :: Flag Bool,-    haddockBenchmarks   :: Flag Bool,-    haddockInternal     :: Flag Bool,-    haddockCss          :: Flag FilePath,-    haddockHscolour     :: Flag Bool,-    haddockHscolourCss  :: Flag FilePath,-    haddockContents     :: Flag PathTemplate,-    haddockDistPref     :: Flag FilePath,-    haddockKeepTempFiles:: Flag Bool,-    haddockVerbosity    :: Flag Verbosity-  }-  deriving Show--defaultHaddockFlags :: HaddockFlags-defaultHaddockFlags  = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = [],-    haddockHoogle       = Flag False,-    haddockHtml         = Flag False,-    haddockHtmlLocation = NoFlag,-    haddockExecutables  = Flag False,-    haddockTestSuites   = Flag False,-    haddockBenchmarks   = Flag False,-    haddockInternal     = Flag False,-    haddockCss          = NoFlag,-    haddockHscolour     = Flag False,-    haddockHscolourCss  = NoFlag,-    haddockContents     = NoFlag,-    haddockDistPref     = Flag defaultDistPref,-    haddockKeepTempFiles= Flag False,-    haddockVerbosity    = Flag normal-  }--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        = \pname ->-      "Usage: " ++ pname ++ " haddock [FLAGS]\n"-  , commandDefaultFlags = defaultHaddockFlags-  , commandOptions      = \showOrParseArgs ->-         haddockOptions showOrParseArgs-      ++ programConfigurationPaths   progConf ParseArgs-             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})-      ++ programConfigurationOption  progConf showOrParseArgs-             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })-      ++ programConfigurationOptions progConf ParseArgs-             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})-  }-  where-    progConf = addKnownProgram haddockProgram-             $ addKnownProgram ghcProgram-             $ emptyProgramConfiguration--haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]-haddockOptions showOrParseArgs =-  [optionVerbosity haddockVerbosity-   (\v flags -> flags { haddockVerbosity = v })-  ,optionDistPref-   haddockDistPref (\d flags -> flags { haddockDistPref = d })-   showOrParseArgs--  ,option "" ["keep-temp-files"]-   "Keep temporary files"-   haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })-   trueArg--  ,option "" ["hoogle"]-   "Generate a hoogle database"-   haddockHoogle (\v flags -> flags { haddockHoogle = v })-   trueArg--  ,option "" ["html"]-   "Generate HTML documentation (the default)"-   haddockHtml (\v flags -> flags { haddockHtml = v })-   trueArg--  ,option "" ["html-location"]-   "Location of HTML documentation for pre-requisite packages"-   haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })-   (reqArgFlag "URL")--  ,option "" ["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 "" ["all"]-   "Run haddock for all targets"-   (\f -> allFlags [ haddockExecutables f-                   , haddockTestSuites  f-                   , haddockBenchmarks  f])-         (\v flags -> flags { haddockExecutables = v-                            , haddockTestSuites  = v-                            , haddockBenchmarks  = 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))-  ]--emptyHaddockFlags :: HaddockFlags-emptyHaddockFlags = mempty--instance Monoid HaddockFlags where-  mempty = HaddockFlags {-    haddockProgramPaths = mempty,-    haddockProgramArgs  = mempty,-    haddockHoogle       = mempty,-    haddockHtml         = mempty,-    haddockHtmlLocation = mempty,-    haddockExecutables  = mempty,-    haddockTestSuites   = mempty,-    haddockBenchmarks   = mempty,-    haddockInternal     = mempty,-    haddockCss          = mempty,-    haddockHscolour     = mempty,-    haddockHscolourCss  = mempty,-    haddockContents     = mempty,-    haddockDistPref     = mempty,-    haddockKeepTempFiles= 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,-    haddockTestSuites   = combine haddockTestSuites,-    haddockBenchmarks   = combine haddockBenchmarks,-    haddockInternal     = combine haddockInternal,-    haddockCss          = combine haddockCss,-    haddockHscolour     = combine haddockHscolour,-    haddockHscolourCss  = combine haddockHscolourCss,-    haddockContents     = combine haddockContents,-    haddockDistPref     = combine haddockDistPref,-    haddockKeepTempFiles= combine haddockKeepTempFiles,-    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 = CommandUI-  { commandName         = "clean"-  , commandSynopsis     = "Clean up after a build."-  , commandDescription  = Just $ \_ ->-      "Removes .hi, .o, preprocessed sources, etc.\n"-  , commandNotes        = Nothing-  , commandUsage        = \pname ->-      "Usage: " ++ pname ++ " clean [FLAGS]\n"-  , commandDefaultFlags = defaultCleanFlags-  , commandOptions      = \showOrParseArgs ->-      [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })-      ,optionDistPref-         cleanDistPref (\d flags -> flags { cleanDistPref = d })-         showOrParseArgs--      ,option "s" ["save-configure"]-         "Do not remove the configuration file (dist/setup-config) during cleaning.  Saves need to reconfigure."-         cleanSaveConf (\v flags -> flags { cleanSaveConf = v })-         trueArg-      ]-  }--emptyCleanFlags :: CleanFlags-emptyCleanFlags = mempty--instance Monoid CleanFlags where-  mempty = 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,-    buildNumJobs     :: Flag (Maybe Int),-    -- TODO: this one should not be here, it's just that the silly-    -- UserHooks stop us from passing extra info in other ways-    buildArgs :: [String]-  }-  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,-    buildNumJobs     = mempty,-    buildArgs        = []-  }--buildCommand :: ProgramConfiguration -> CommandUI BuildFlags-buildCommand progConf = 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 progConf---TODO: re-enable once we have support for module/file targets---        ++ "  " ++ pname ++ " build Foo.Bar   "---        ++ "    A module\n"---        ++ "  " ++ pname ++ " build Foo/Bar.hs"---        ++ "    A file\n\n"---        ++ "If a target is ambiguous it can be qualified with the component "---        ++ "name, e.g.\n"---        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"---        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"-  , commandUsage        = usageAlternatives "build" $-      [ "[FLAGS]"-      , "COMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultBuildFlags-  , commandOptions      = \showOrParseArgs ->-      [ optionVerbosity-        buildVerbosity (\v flags -> flags { buildVerbosity = v })--      , optionDistPref-        buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs-      ]-      ++ buildOptions progConf showOrParseArgs-  }--buildOptions :: ProgramConfiguration -> ShowOrParseArgs-                -> [OptionField BuildFlags]-buildOptions progConf showOrParseArgs =-  [ optionNumJobs-      buildNumJobs (\v flags -> flags { buildNumJobs = v })-  ]--  ++ programConfigurationPaths progConf showOrParseArgs-       buildProgramPaths (\v flags -> flags { buildProgramPaths = v})--  ++ programConfigurationOption progConf showOrParseArgs-       buildProgramArgs (\v fs -> fs { buildProgramArgs = 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,-    buildNumJobs     = mempty,-    buildArgs        = mempty-  }-  mappend a b = BuildFlags {-    buildProgramPaths = combine buildProgramPaths,-    buildProgramArgs = combine buildProgramArgs,-    buildVerbosity   = combine buildVerbosity,-    buildDistPref    = combine buildDistPref,-    buildNumJobs     = combine buildNumJobs,-    buildArgs        = combine buildArgs-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * REPL Flags--- --------------------------------------------------------------data ReplFlags = ReplFlags {-    replProgramPaths :: [(String, FilePath)],-    replProgramArgs :: [(String, [String])],-    replDistPref    :: Flag FilePath,-    replVerbosity   :: Flag Verbosity,-    replReload      :: Flag Bool-  }-  deriving Show--defaultReplFlags :: ReplFlags-defaultReplFlags  = ReplFlags {-    replProgramPaths = mempty,-    replProgramArgs = [],-    replDistPref    = Flag defaultDistPref,-    replVerbosity   = Flag normal,-    replReload      = Flag False-  }--instance Monoid ReplFlags where-  mempty = ReplFlags {-    replProgramPaths = mempty,-    replProgramArgs = mempty,-    replVerbosity   = mempty,-    replDistPref    = mempty,-    replReload      = mempty-  }-  mappend a b = ReplFlags {-    replProgramPaths = combine replProgramPaths,-    replProgramArgs = combine replProgramArgs,-    replVerbosity   = combine replVerbosity,-    replDistPref    = combine replDistPref,-    replReload      = combine replReload-  }-    where combine field = field a `mappend` field b--replCommand :: ProgramConfiguration -> CommandUI ReplFlags-replCommand progConf = CommandUI-  { commandName         = "repl"-  , commandSynopsis     =-      "Open an interpreter session for the given component."-  , commandDescription  = Just $ \pname -> wrapText $-         "If the current directory contains no package, ignores COMPONENT "-      ++ "parameters and opens an interactive interpreter session; if a "-      ++ "sandbox is present, its package database will be used.\n"-      ++ "\n"-      ++ "Otherwise, (re)configures with the given or default flags, and "-      ++ "loads the interpreter with the relevant modules. For executables, "-      ++ "tests and benchmarks, loads the main module (and its "-      ++ "dependencies); for libraries all exposed/other modules.\n"-      ++ "\n"-      ++ "The default component is the library itself, or the executable "-      ++ "if that is the only component.\n"-      ++ "\n"-      ++ "Support for loading specific modules is planned but not "-      ++ "implemented yet. For certain scenarios, `" ++ pname-      ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "-      ++ "not (re)configure and you will have to specify the location of "-      ++ "other modules, if required.\n"--  , commandNotes        = Just $ \pname ->-         "Examples:\n"-      ++ "  " ++ pname ++ " repl           "-      ++ "    The first component in the package\n"-      ++ "  " ++ pname ++ " repl foo       "-      ++ "    A named component (i.e. lib, exe, test suite)\n"-      ++ "  " ++ pname ++ " repl --ghc-options=\"-lstdc++\""-      ++ "  Specifying flags for interpreter\n"---TODO: re-enable once we have support for module/file targets---        ++ "  " ++ pname ++ " repl Foo.Bar   "---        ++ "    A module\n"---        ++ "  " ++ pname ++ " repl Foo/Bar.hs"---        ++ "    A file\n\n"---        ++ "If a target is ambiguous it can be qualified with the component "---        ++ "name, e.g.\n"---        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"---        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"-  , commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"-  , commandDefaultFlags = defaultReplFlags-  , commandOptions = \showOrParseArgs ->-      optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })-      : optionDistPref-          replDistPref (\d flags -> flags { replDistPref = d })-          showOrParseArgs--      : programConfigurationPaths   progConf showOrParseArgs-          replProgramPaths (\v flags -> flags { replProgramPaths = v})--     ++ programConfigurationOption progConf showOrParseArgs-          replProgramArgs (\v flags -> flags { replProgramArgs = v})--     ++ programConfigurationOptions progConf 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-            ]-          _ -> []-  }---- --------------------------------------------------------------- * Test flags--- --------------------------------------------------------------data TestShowDetails = Never | Failures | Always | Streaming-    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: 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,-    testOptions     = []-  }--testCommand :: CommandUI TestFlags-testCommand = CommandUI-  { commandName         = "test"-  , commandSynopsis     =-      "Run all/specific tests in the test suite."-  , commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-tests` flag and builds"-      ++ " the test suite.\n"-      ++ "\n"-      ++ "Remember that the tests' dependencies must be installed if there"-      ++ " are additional ones; e.g. with `" ++ pname-      ++ " install --only-dependencies --enable-tests`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running tests.\n"-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives "test"-      [ "[FLAGS]"-      , "TESTCOMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultTestFlags-  , commandOptions = \showOrParseArgs ->-      [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })-      , optionDistPref-            testDistPref (\d flags -> flags { testDistPref = d })-            showOrParseArgs-      , option [] ["log"]-            ("Log all test suite results to file (name template can use "-            ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)")-            testHumanLog (\v flags -> flags { testHumanLog = v })-            (reqArg' "TEMPLATE"-                (toFlag . toPathTemplate)-                (flagToList . fmap fromPathTemplate))-      , option [] ["machine-log"]-            ("Produce a machine-readable log file (name template can use "-            ++ "$pkgid, $compiler, $os, $arch, $result)")-            testMachineLog (\v flags -> flags { testMachineLog = v })-            (reqArg' "TEMPLATE"-                (toFlag . toPathTemplate)-                (flagToList . fmap fromPathTemplate))-      , option [] ["show-details"]-            ("'always': always show results of individual test cases. "-             ++ "'never': never show results of individual test cases. "-             ++ "'failures': show results of failing test cases. "-             ++ "'streaming': show results of test cases in real time.")-            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,-    testOptions     = mempty-  }-  mappend a b = TestFlags {-    testDistPref    = combine testDistPref,-    testVerbosity   = combine testVerbosity,-    testHumanLog    = combine testHumanLog,-    testMachineLog  = combine testMachineLog,-    testShowDetails = combine testShowDetails,-    testKeepTix     = combine testKeepTix,-    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 = CommandUI-  { commandName         = "bench"-  , commandSynopsis     =-      "Run all/specific benchmarks."-  , commandDescription  = Just $ \pname -> wrapText $-         "If necessary (re)configures with `--enable-benchmarks` flag and"-      ++ " builds the benchmarks.\n"-      ++ "\n"-      ++ "Remember that the benchmarks' dependencies must be installed if"-      ++ " there are additional ones; e.g. with `" ++ pname-      ++ " install --only-dependencies --enable-benchmarks`.\n"-      ++ "\n"-      ++ "By defining UserHooks in a custom Setup.hs, the package can"-      ++ " define actions to be executed before and after running"-      ++ " benchmarks.\n"-  , commandNotes        = Nothing-  , commandUsage        = usageAlternatives "bench"-      [ "[FLAGS]"-      , "BENCHCOMPONENTS [FLAGS]"-      ]-  , commandDefaultFlags = defaultBenchmarkFlags-  , commandOptions = \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"---- | For each known program @PROG@ in 'progConf', produce a @with-PROG@--- 'OptionField'.-programConfigurationPaths-  :: ProgramConfiguration-  -> ShowOrParseArgs-  -> (flags -> [(String, FilePath)])-  -> ([(String, FilePath)] -> (flags -> flags))-  -> [OptionField flags]-programConfigurationPaths progConf showOrParseArgs get set =-  programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set---- | Like 'programConfigurationPaths', but allows to customise the option name.-programConfigurationPaths'-  :: (String -> String)-  -> ProgramConfiguration-  -> ShowOrParseArgs-  -> (flags -> [(String, FilePath)])-  -> ([(String, FilePath)] -> (flags -> flags))-  -> [OptionField flags]-programConfigurationPaths' mkName 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 "" [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 'progConf', produce a @PROG-option@--- 'OptionField'.-programConfigurationOption-  :: ProgramConfiguration-  -> ShowOrParseArgs-  -> (flags -> [(String, [String])])-  -> ([(String, [String])] -> (flags -> flags))-  -> [OptionField flags]-programConfigurationOption progConf 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 progConf)-  where-    programOption prog =-      option "" [prog ++ "-option"]-        ("give an extra option to " ++ prog ++-         " (no need to quote options containing spaces)")-        get set-        (reqArg' "OPT" (\arg -> [(prog, [arg])])-           (\progArgs -> concat [ args-                                | (prog', args) <- progArgs, prog==prog' ]))---- | For each known program @PROG@ in 'progConf', produce a @PROG-options@--- 'OptionField'.-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"]-    ParseArgs -> map (programOptions . programName . fst)-                 (knownPrograms progConf)-  where-    programOptions prog =-      option "" [prog ++ "-options"]-        ("give extra options to " ++ prog)-        get set-        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))---- --------------------------------------------------------------- * GetOpt Utils--- --------------------------------------------------------------boolOpt :: SFlags -> SFlags-           -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt  = Command.boolOpt  flagToMaybe Flag--boolOpt' :: OptFlags -> OptFlags-            -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt' = Command.boolOpt' flagToMaybe Flag--trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-trueArg  sfT lfT = boolOpt' (sfT, lfT) ([], [])   sfT lfT-falseArg sfF lfF = boolOpt' ([],  [])  (sfF, lfF) sfF lfF--reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->-              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList--optionDistPref :: (flags -> Flag FilePath)-               -> (Flag FilePath -> flags -> flags)-               -> ShowOrParseArgs-               -> OptionField flags-optionDistPref get set = \showOrParseArgs ->-  option "" (distPrefFlagName showOrParseArgs)-    (   "The directory where Cabal puts generated build files "-     ++ "(default " ++ defaultDistPref ++ ")")-    get set-    (reqArgFlag "DIR")-  where-    distPrefFlagName ShowArgs  = ["builddir"]-    distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"]--optionVerbosity :: (flags -> Flag Verbosity)-                -> (Flag Verbosity -> flags -> flags)-                -> OptionField flags-optionVerbosity get set =-  option "v" ["verbose"]-    "Control verbosity (n is 0--3, default verbosity level is 1)"-    get set-    (optArg "n" (fmap Flag flagToVerbosity)-                (Flag verbose) -- default Value if no n is given-                (fmap (Just . showForCabal) . flagToList))--optionNumJobs :: (flags -> Flag (Maybe Int))-              -> (Flag (Maybe Int) -> flags -> flags)-              -> OptionField flags-optionNumJobs get set =-  option "j" ["jobs"]-    "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."-    get set-    (optArg "NUM" (fmap Flag numJobsParser)-                  (Flag Nothing)-                  (map (Just . maybe "$ncpus" show) . flagToList))-  where-    numJobsParser :: ReadE (Maybe Int)-    numJobsParser = ReadE $ \s ->-      case s of-        "$ncpus" -> Right Nothing-        _        -> case reads s of-          [(n, "")]-            | n < 1     -> Left "The number of jobs should be 1 or more."-            | otherwise -> Right (Just n)-          _             -> Left "The jobs value should be a number or '$ncpus'"---- --------------------------------------------------------------- * Other Utils--- ---------------------------------------------------------------- | Arguments to pass to a @configure@ script, e.g. generated by--- @autoconf@.-configureArgs :: Bool -> ConfigFlags -> [String]-configureArgs bcHack flags-  = hc_flag- ++ optFlag  "with-hc-pkg" configHcPkg- ++ optFlag' "prefix"      prefix- ++ optFlag' "bindir"      bindir- ++ optFlag' "libdir"      libdir- ++ optFlag' "libexecdir"  libexecdir- ++ optFlag' "datadir"     datadir- ++ optFlag' "sysconfdir"  sysconfdir- ++ configConfigureArgs flags-  where-        hc_flag = case (configHcFlavor flags, configHcPath flags) of-                        (_, Flag hc_path) -> [hc_flag_name ++ hc_path]-                        (Flag hc, NoFlag) -> [hc_flag_name ++ 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,490 +0,0 @@--------------------------------------------------------------------------------- |--- 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.---- NOTE: FIX: we don't have a great way of testing this module, since--- we can't easily look inside a tarball once its created.--module Distribution.Simple.SrcDist (-  -- * The top level action-  sdist,--  -- ** Parts of 'sdist'-  printPackageProblems,-  prepareTree,-  createArchive,--  -- ** Snapshots-  prepareSnapshotTree,-  snapshotPackage,-  snapshotVersion,-  dateToSnapshotNumber,--  -- * Extracting the source files-  listPackageSources--  )  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-         , installOrdinaryFiles, installMaybeExecutableFiles-         , findFile, findFileWithExtension, matchFileGlob-         , withTempDirectory, defaultPackageDesc-         , die, warn, notice, info, setupMessage )-import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)-                                 , fromFlag, flagToMaybe)-import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes-                                      , preprocessComponent )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), withAllComponentsInBuildOrder )-import Distribution.Simple.BuildPaths ( autogenModuleName )-import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,-                                     runProgram, programProperties, tarProgram )-import Distribution.Text-         ( display )--import Control.Monad(when, unless, forM)-import Data.Char (toLower)-import Data.List (partition, isPrefixOf)-import qualified Data.Map as Map-import Data.Maybe (isNothing, catMaybes)-import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)-import System.Directory ( doesFileExist )-import System.IO (IOMode(WriteMode), hPutStrLn, withFile)-import Distribution.Verbosity (Verbosity)-import System.FilePath-         ( (</>), (<.>), 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 =--  -- 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, maybeExecutable) <- listPackageSources verbosity pkg pps-      mapM_ (hPutStrLn outHandle) ordinary-      mapM_ (hPutStrLn outHandle) maybeExecutable-      notice verbosity $ "List of package sources written to file '"-                         ++ path ++ "'"-    NoFlag    -> do-      -- do some QA-      printPackageProblems verbosity pkg--      when (isNothing mb_lbi) $-        warn verbosity "Cannot run preprocessors. Run 'configure' command first."--      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' 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 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---- | List all source files of a package. Returns a tuple of lists: first--- component is a list of ordinary files, second one is a list of those files--- that may be executable.-listPackageSources :: Verbosity          -- ^ verbosity-                   -> PackageDescription -- ^ info from the cabal file-                   -> [PPSuffixHandler]  -- ^ extra preprocessors (include-                                         -- suffixes)-                   -> IO ([FilePath], [FilePath])-listPackageSources verbosity pkg_descr0 pps = do-  -- Call helpers that actually do all work.-  ordinary        <- listPackageSourcesOrdinary        verbosity pkg_descr pps-  maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr-  return (ordinary, maybeExecutable)-  where-    pkg_descr = filterAutogenModule pkg_descr0---- | List those source files that may be executable (e.g. the configure script).-listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath]-listPackageSourcesMaybeExecutable pkg_descr =-  -- Extra source files.-  fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath---- | List those source files that should be copied with ordinary permissions.-listPackageSourcesOrdinary :: Verbosity-                           -> PackageDescription-                           -> [PPSuffixHandler]-                           -> IO [FilePath]-listPackageSourcesOrdinary verbosity pkg_descr pps =-  fmap concat . sequence $-  [-    -- Library sources.-    withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->-     allSourcesBuildInfo libBi pps modules--    -- Executables sources.-  , fmap concat-    . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do-       biSrcs  <- allSourcesBuildInfo exeBi pps []-       mainSrc <- findMainExeFile exeBi pps mainPath-       return (mainSrc:biSrcs)--    -- Test suites sources.-  , fmap concat-    . withTest $ \t -> do-       let bi  = testBuildInfo t-       case testInterface t of-         TestSuiteExeV10 _ mainPath -> do-           biSrcs <- allSourcesBuildInfo bi pps []-           srcMainFile <- do-             ppFile <- findFileWithExtension (ppSuffixes pps)-                       (hsSourceDirs bi) (dropExtension mainPath)-             case ppFile of-               Nothing -> findFile (hsSourceDirs bi) mainPath-               Just pp -> return pp-           return (srcMainFile:biSrcs)-         TestSuiteLibV09 _ m ->-           allSourcesBuildInfo bi pps [m]-         TestSuiteUnsupported tp -> die $ "Unsupported test suite type: "-                                   ++ show tp--    -- Benchmarks sources.-  , fmap concat-    . withBenchmark $ \bm -> do-       let  bi = benchmarkBuildInfo bm-       case benchmarkInterface bm of-         BenchmarkExeV10 _ mainPath -> do-           biSrcs <- allSourcesBuildInfo bi pps []-           srcMainFile <- do-             ppFile <- findFileWithExtension (ppSuffixes pps)-                       (hsSourceDirs bi) (dropExtension mainPath)-             case ppFile of-               Nothing -> findFile (hsSourceDirs bi) mainPath-               Just pp -> return pp-           return (srcMainFile:biSrcs)-         BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "-                                    ++ show tp--    -- Data files.-  , fmap concat-    . forM (dataFiles pkg_descr) $ \filename ->-       matchFileGlob (dataDir pkg_descr </> filename)--    -- Extra doc files.-  , fmap concat-    . forM (extraDocFiles pkg_descr) $ \ filename ->-      matchFileGlob filename--    -- License file(s).-  , return (licenseFiles pkg_descr)--    -- Install-include files.-  , withLib $ \ l -> do-       let lbi = libBuildInfo l-           relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-       mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)--    -- Setup script, if it exists.-  , fmap (maybe [] (\f -> [f])) $ findSetupFile ""--    -- The .cabal file itself.-  , fmap (\d -> [d]) (defaultPackageDesc verbosity)--  ]-  where-    -- 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.-prepareTree :: Verbosity          -- ^verbosity-            -> PackageDescription -- ^info from the cabal file-            -> Maybe LocalBuildInfo-            -> FilePath           -- ^source tree to populate-            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-            -> IO ()-prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do-  -- 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 }-      withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ ->-        preprocessComponent pkg_descr c lbi' True verbosity pps-    _ -> return ()--  (ordinary, mExecutable)  <- listPackageSources verbosity pkg_descr0 pps-  installOrdinaryFiles        verbosity targetDir (zip (repeat []) ordinary)-  installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)-  maybeCreateDefaultSetupScript targetDir--  where-    pkg_descr = filterAutogenModule pkg_descr0---- | Find the setup script file, if it exists.-findSetupFile :: FilePath -> IO (Maybe FilePath)-findSetupFile targetDir = do-  hsExists  <- doesFileExist setupHs-  lhsExists <- doesFileExist setupLhs-  if hsExists-    then return (Just setupHs)-    else if lhsExists-         then return (Just setupLhs)-         else return Nothing-    where-      setupHs  = targetDir </> "Setup.hs"-      setupLhs = targetDir </> "Setup.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 :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath-findMainExeFile exeBi pps mainPath = do-  ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)-            (dropExtension mainPath)-  case ppFile of-    Nothing -> findFile (hsSourceDirs exeBi) mainPath-    Just pp -> return pp---- | 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 :: [FilePath] -> String -> IO (String, FilePath)-findIncludeFile [] f = die ("can't find include file " ++ f)-findIncludeFile (d:ds) f = do-  let path = (d </> f)-  b <- doesFileExist path-  if b then return (f,path) else findIncludeFile ds f---- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and--- 'other-modules'.-filterAutogenModule :: PackageDescription -> PackageDescription-filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $-                                 mapAllBuildInfo filterAutogenModuleBI pkg_descr0-  where-    mapLib f pkg = pkg { library = fmap f (library pkg) }-    filterAutogenModuleLib lib = lib {-      exposedModules = filter (/=autogenModule) (exposedModules lib)-    }-    filterAutogenModuleBI bi = bi {-      otherModules   = filter (/=autogenModule) (otherModules bi)-    }-    autogenModule = autogenModuleName pkg_descr0---- | 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           -- ^source tree to populate-                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes-                                          -- suffixes)-                    -> IO ()-prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do-  prepareTree verbosity pkg mb_lbi 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 :: 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 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 :: UTCTime -> Int-dateToSnapshotNumber date = case toGregorian (utctDay date) of-                            (year, month, day) ->-                                fromIntegral year * 10000-                              + month             * 100-                              + day---- | Callback type for use by sdistWith.-type CreateArchiveFun = 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---- | Create an archive from a tree of source files, and clean up the tree.-createArchive :: CreateArchiveFun-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)-  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 :: BuildInfo-                       -> [PPSuffixHandler] -- ^ Extra preprocessors-                       -> [ModuleName]      -- ^ Exposed modules-                       -> IO [FilePath]-allSourcesBuildInfo bi pps modules = 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 ]--  return $ sources ++ catMaybes bootFiles ++ cSources bi ++ jsSources bi--  where-    suffixes = ppSuffixes pps ++ ["hs", "lhs"]-    notFound m = die $ "Error: Could not find module: " ++ display m-                 ++ " with any suffix: " ++ show suffixes---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,136 +0,0 @@--------------------------------------------------------------------------------- |--- 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 qualified Distribution.PackageDescription as PD-         ( PackageDescription(..), BuildInfo(buildable)-         , TestSuite(..)-         , TestSuiteInterface(..), testType, hasTests )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( markupPackage )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, substPathTemplate-    , PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-    ( LocalBuildInfo(..) )-import Distribution.Simple.Setup ( TestFlags(..), fromFlag, configCoverage )-import Distribution.Simple.UserHooks ( Args )-import qualified Distribution.Simple.Test.ExeV10 as ExeV10-import qualified Distribution.Simple.Test.LibV09 as LibV09-import Distribution.Simple.Test.Log-import Distribution.Simple.Utils ( die, notice )-import Distribution.TestSuite ( Result(..) )-import Distribution.Text--import Control.Monad ( when, unless, filterM )-import System.Directory-    ( createDirectoryIfMissing, doesFileExist, getDirectoryContents-    , removeFile )-import System.Exit ( ExitCode(..), exitFailure, exitWith )-import System.FilePath ( (</>) )---- |Perform the \"@.\/setup test@\" action.-test :: Args                    -- ^positional command-line arguments-     -> PD.PackageDescription   -- ^information from the .cabal file-     -> LBI.LocalBuildInfo      -- ^information from the configure step-     -> TestFlags               -- ^flags sent to test-     -> IO ()-test args pkg_descr lbi flags = do-    let verbosity = fromFlag $ testVerbosity flags-        machineTemplate = fromFlag $ testMachineLog flags-        distPref = fromFlag $ testDistPref flags-        testLogDir = distPref </> "test"-        testNames = args-        pkgTests = PD.testSuites pkg_descr-        enabledTests = [ t | t <- pkgTests-                           , PD.testEnabled t-                           , PD.buildable (PD.testBuildInfo t) ]--        doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog-        doTest (suite, _) =-            case PD.testInterface suite of-              PD.TestSuiteExeV10 _ _ ->-                  ExeV10.runTest pkg_descr lbi flags suite--              PD.TestSuiteLibV09 _ _ ->-                  LibV09.runTest pkg_descr lbi flags suite--              _ -> return TestSuiteLog-                  { testSuiteName = PD.testName suite-                  , testLogs = TestLog-                      { testName = PD.testName suite-                      , testOptionsReturned = []-                      , testResult =-                          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--    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi-    when isCoverageEnabled $-        markupPackage verbosity lbi distPref (display $ PD.package pkg_descr) $-            map 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.pkgKey lbi)-                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
− Distribution/Simple/Test/ExeV10.hs 
@@ -1,168 +0,0 @@-module Distribution.Simple.Test.ExeV10-       ( runTest-       ) where--import Distribution.Compat.CreatePipe ( createPipe )-import Distribution.Compat.Environment ( getEnvironment )-import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup-    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )-import Distribution.Simple.Test.Log-import Distribution.Simple.Utils-    ( die, notice, rawSystemIOWithEnv, addLibraryPath )-import Distribution.System ( Platform (..) )-import Distribution.TestSuite-import Distribution.Text-import Distribution.Verbosity ( normal )--import Control.Concurrent (forkIO)-import Control.Monad ( unless, void, when )-import System.Directory-    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-    , getCurrentDirectory, removeDirectoryRecursive )-import System.Exit ( ExitCode(..) )-import System.FilePath ( (</>), (<.>) )-import System.IO ( hGetContents, hPutStr, stdout )--runTest :: PD.PackageDescription-        -> LBI.LocalBuildInfo-        -> TestFlags-        -> PD.TestSuite-        -> IO TestSuiteLog-runTest pkg_descr lbi flags suite = do-    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi-        way = guessWay lbi-        tixDir_ = tixDir distPref way $ PD.testName suite--    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment--    let cmd = LBI.buildDir lbi </> PD.testName suite-                  </> PD.testName suite <.> exeExtension-    -- 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-        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 $ PD.testName suite--    (rOut, wOut) <- createPipe--    -- Read test executable's output lazily (returns immediately)-    logText <- hGetContents rOut-    -- Force the IO manager to drain the test output pipe-    void $ forkIO $ length logText `seq` return ()--    -- '--show-details=streaming': print the log output in another thread-    when (details == Streaming) $ void $ forkIO $ hPutStr stdout logText--    -- Run the test executable-    let opts = map (testOption pkg_descr lbi suite)-                   (testOptions flags)-        dataDirPath = pwd </> PD.dataDir pkg_descr-        tixFile = pwd </> tixFilePath distPref way (PD.testName suite)-        pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                   : existingEnv-        shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv--    -- Add (DY)LD_LIBRARY_PATH if needed-    shellEnv' <- if LBI.withDynExe lbi-                    then do let (Platform _ os) = LBI.hostPlatform lbi-                                clbi = LBI.getComponentLocalBuildInfo lbi-                                         (LBI.CTestName (PD.testName suite))-                            paths <- LBI.depLibraryPaths True False lbi clbi-                            return (addLibraryPath os paths shellEnv)-                    else return shellEnv--    exit <- rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')-                               -- these handles are automatically closed-                               Nothing (Just wOut) (Just wOut)--    -- 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 $ PD.testName suite--    -- Append contents of temporary log file to the final human--    -- readable log file-    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 > Never)-            && (not (suitePassed $ testLogs suiteLog) || details == Always)-            -- verbosity overrides show-details-            && verbosity >= normal-            -- if streaming, we already printed the log-            && details /= Streaming-    whenPrinting $ putStr $ unlines $ lines logText--    -- Write summary notice to terminal indicating end of test suite-    notice verbosity $ summarizeSuiteFinish suiteLog--    when isCoverageEnabled $-        markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite--    return suiteLog-  where-    distPref = fromFlag $ testDistPref flags-    verbosity = fromFlag $ testVerbosity flags-    details = fromFlag $ testShowDetails flags-    testLogDir = distPref </> "test"--    buildLog exit =-        let r = case exit of-                    ExitSuccess -> Pass-                    ExitFailure c -> Fail $ "exit code: " ++ show c-            n = PD.testName suite-            l = TestLog-                { testName = n-                , testOptionsReturned = []-                , testResult = r-                }-        in TestSuiteLog-                { testSuiteName = n-                , testLogs = l-                , logFile =-                    testLogDir-                    </> testSuiteLogPath (fromFlag $ testHumanLog flags)-                                         pkg_descr lbi n 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.pkgKey lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]
− Distribution/Simple/Test/LibV09.hs 
@@ -1,258 +0,0 @@-module Distribution.Simple.Test.LibV09-       ( runTest-         -- Test stub-       , simpleTestStub-       , stubFilePath, stubMain, stubName, stubWriteLog-       , writeSimpleTestStub-       ) where--import Distribution.Compat.CreatePipe ( createPipe )-import Distribution.Compat.Environment ( getEnvironment )-import Distribution.Compat.TempFile ( openTempFile )-import Distribution.ModuleName ( ModuleName )-import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )-import Distribution.Simple.BuildPaths ( exeExtension )-import Distribution.Simple.Compiler ( compilerInfo )-import Distribution.Simple.Hpc ( guessWay, markupTest, tixDir, tixFilePath )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup-    ( TestFlags(..), TestShowDetails(..), fromFlag, configCoverage )-import Distribution.Simple.Test.Log-import Distribution.Simple.Utils-    ( die, notice, rawSystemIOWithEnv, addLibraryPath )-import Distribution.System ( Platform (..) )-import Distribution.TestSuite-import Distribution.Text-import Distribution.Verbosity ( normal )--import Control.Exception ( bracket )-import Control.Monad ( when, unless )-import Data.Maybe ( mapMaybe )-import System.Directory-    ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-    , getCurrentDirectory, removeDirectoryRecursive, removeFile-    , setCurrentDirectory )-import System.Exit ( ExitCode(..), exitWith )-import System.FilePath ( (</>), (<.>) )-import System.IO ( hClose, hGetContents, hPutStr )--runTest :: PD.PackageDescription-        -> LBI.LocalBuildInfo-        -> TestFlags-        -> PD.TestSuite-        -> IO TestSuiteLog-runTest pkg_descr lbi flags suite = do-    let isCoverageEnabled = fromFlag $ configCoverage $ LBI.configFlags lbi-        way = guessWay lbi--    pwd <- getCurrentDirectory-    existingEnv <- getEnvironment--    let cmd = LBI.buildDir lbi </> stubName suite-                  </> stubName suite <.> exeExtension-    -- 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 way $ PD.testName suite-        exists' <- doesDirectoryExist tDir-        when exists' $ removeDirectoryRecursive tDir--    -- Create directory for HPC files.-    createDirectoryIfMissing True $ tixDir distPref way $ PD.testName suite--    -- Write summary notices indicating start of test suite-    notice verbosity $ summarizeSuiteStart $ PD.testName suite--    suiteLog <- bracket openCabalTemp deleteIfExists $ \tempLog -> do--        (rIn, wIn) <- createPipe-        (rOut, wOut) <- createPipe--        -- Prepare standard input for test executable-        --appendFile tempInput $ show (tempInput, PD.testName suite)-        hPutStr wIn $ show (tempLog, PD.testName suite)-        hClose wIn--        -- Run test executable-        _ <- do let opts = map (testOption pkg_descr lbi suite) $ testOptions flags-                    dataDirPath = pwd </> PD.dataDir pkg_descr-                    tixFile = pwd </> tixFilePath distPref way (PD.testName suite)-                    pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                               : existingEnv-                    shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]-                             ++ pkgPathEnv-                -- Add (DY)LD_LIBRARY_PATH if needed-                shellEnv' <- if LBI.withDynExe lbi-                                then do-                                  let (Platform _ os) = LBI.hostPlatform lbi-                                      clbi = LBI.getComponentLocalBuildInfo-                                                   lbi-                                                   (LBI.CTestName-                                                      (PD.testName suite))-                                  paths <- LBI.depLibraryPaths-                                             True False lbi clbi-                                  return (addLibraryPath os paths shellEnv)-                                else return shellEnv-                rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv')-                                   -- these handles are closed automatically-                                   (Just rIn) (Just wOut) (Just wOut)--        -- Generate final log file name-        let finalLogName l = testLogDir-                             </> testSuiteLogPath-                                 (fromFlag $ testHumanLog flags) pkg_descr lbi-                                 (testSuiteName l) (testLogs l)-        -- Generate TestSuiteLog from executable exit code and a machine--        -- readable test log-        suiteLog <- fmap ((\l -> l { logFile = finalLogName l }) . read)-                    $ readFile tempLog--        -- 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-        logText <- hGetContents rOut-        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 $ putStr $ unlines $ lines logText--        return suiteLog--    -- Write summary notice to terminal indicating end of test suite-    notice verbosity $ summarizeSuiteFinish suiteLog--    when isCoverageEnabled $-        markupTest verbosity lbi distPref (display $ PD.package pkg_descr) suite--    return suiteLog-  where-    deleteIfExists file = do-        exists <- doesFileExist file-        when exists $ removeFile file--    testLogDir = distPref </> "test"-    openCabalTemp = do-        (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"-        hClose h >> return f--    distPref = fromFlag $ testDistPref flags-    verbosity = fromFlag $ testVerbosity flags---- TODO: This is abusing the notion of a 'PathTemplate'.  The result isn't--- necessarily a path.-testOption :: PD.PackageDescription-           -> LBI.LocalBuildInfo-           -> PD.TestSuite-           -> PathTemplate-           -> String-testOption pkg_descr lbi suite template =-    fromPathTemplate $ substPathTemplate env template-  where-    env = initialPathTemplateEnv-          (PD.package pkg_descr) (LBI.pkgKey lbi)-          (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++-          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]---- Test stub -------------- | The name of the stub executable associated with a library 'TestSuite'.-stubName :: PD.TestSuite -> FilePath-stubName t = PD.testName t ++ "Stub"---- | The filename of the source file for the stub executable associated with a--- library 'TestSuite'.-stubFilePath :: PD.TestSuite -> FilePath-stubFilePath t = stubName t <.> "hs"---- | Write the source file for a library 'TestSuite' stub executable.-writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub-                                    -- is being created-                    -> FilePath     -- ^ path to directory where stub source-                                    -- should be located-                    -> IO ()-writeSimpleTestStub 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 Distribution.Simple.Test.LibV09 ( stubMain )"-    , "import " ++ show (disp 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 read getContents-    dir <- getCurrentDirectory-    results <- tests >>= stubRunTests-    setCurrentDirectory dir-    stubWriteLog f n results---- | 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 <- mapM 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 <- mapM 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 -> String -> 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-    exitWith ExitSuccess
− Distribution/Simple/Test/Log.hs 
@@ -1,161 +0,0 @@-module Distribution.Simple.Test.Log-       ( PackageLog(..)-       , TestLogs(..)-       , TestSuiteLog(..)-       , countTestResults-       , localPackageLog-       , summarizePackage-       , summarizeSuiteFinish, summarizeSuiteStart-       , summarizeTest-       , suiteError, suiteFailed, suitePassed-       , testSuiteLogPath-       ) where--import Distribution.Package ( PackageId )-import qualified Distribution.PackageDescription as PD-import Distribution.Simple.Compiler ( Compiler(..), compilerInfo, CompilerId )-import Distribution.Simple.InstallDirs-    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)-    , substPathTemplate , toPathTemplate, PathTemplate )-import qualified Distribution.Simple.LocalBuildInfo as LBI-import Distribution.Simple.Setup ( TestShowDetails(..) )-import Distribution.Simple.Utils ( notice )-import Distribution.System ( Platform )-import Distribution.TestSuite ( Options, Result(..) )-import Distribution.Verbosity ( Verbosity )--import Control.Monad ( when )-import Data.Char ( toUpper )---- | 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 :: String-    , 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 name result =-    fromPathTemplate $ substPathTemplate env template-    where-        env = initialPathTemplateEnv-                (PD.package pkg_descr) (LBI.pkgKey lbi)-                (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)-                ++  [ (TestSuiteNameVar, toPathTemplate 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) = 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, supressing--- 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 " ++ 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"
− Distribution/Simple/UHC.hs 
@@ -1,276 +0,0 @@--------------------------------------------------------------------------------- |--- 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-  ) where--import Control.Monad-import Data.List-import qualified Data.Map as M ( empty )-import Distribution.Compat.ReadP-import Distribution.InstalledPackageInfo-import Distribution.Package hiding (installedPackageId)-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-import Distribution.System ( Platform )---- -------------------------------------------------------------------------------- Configuring--configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, 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,-               compilerAbiTag     =  C.NoAbiTag,-               compilerCompat     =  [],-               compilerLanguages  =  uhcLanguages,-               compilerExtensions =  uhcLanguageExtensions,-               compilerProperties =  M.empty-             }-      compPlatform = Nothing-  return (comp, compPlatform, 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 InstalledPackageIndex-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-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 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]-     -- cpp options-  ++ ["--optP=" ++ opt | opt <- cppOptions bi]-     -- output path-  ++ ["--odir=" ++ odir]-     -- optimization-  ++ (case withOptimization lbi of-        NoOptimisation       ->  ["-O0"]-        NormalOptimisation   ->  ["-O1"]-        MaximumOptimisation  ->  ["-O2"])--uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]-uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)-                                         (concatMap (packageDbPaths user system) db)---- -------------------------------------------------------------------------------- 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 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-  -> 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,211 +0,0 @@--------------------------------------------------------------------------------- |--- 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.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, ReplFlags, 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 get different behavior during build.-    buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),-    -- |Hook to run after build command.  Second arg indicates verbosity level.-    postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before repl command.  Second arg indicates verbosity level.-    preRepl  :: Args -> ReplFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during interpretation.-    replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),-    -- |Hook to run after repl command.  Second arg indicates verbosity level.-    postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before clean command.  Second arg indicates verbosity level.-    preClean  :: Args -> CleanFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during clean.-    cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (),-    -- |Hook to run after clean command.  Second arg indicates verbosity level.-    postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (),--    -- |Hook to run before copy command-    preCopy  :: Args -> CopyFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during copy.-    copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (),-    -- |Hook to run after copy command-    postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before install command-    preInst  :: Args -> InstallFlags -> IO HookedBuildInfo,--    -- |Over-ride this hook to get different behavior during install.-    instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (),-    -- |Hook to run after install command.  postInst should be run-    -- on the target, not on the build machine.-    postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before 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 unregistration.-    unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),-    -- |Hook to run after unregister command-    postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before hscolour command.  Second arg indicates verbosity level.-    preHscolour  :: Args -> HscolourFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during hscolour.-    hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (),-    -- |Hook to run after hscolour command.  Second arg indicates verbosity level.-    postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before haddock command.  Second arg indicates verbosity level.-    preHaddock  :: Args -> HaddockFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during haddock.-    haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),-    -- |Hook to run after haddock command.  Second arg indicates verbosity level.-    postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before test command.-    preTest :: Args -> TestFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during test.-    testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),-    -- |Hook to run after test command.-    postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),--    -- |Hook to run before bench command.-    preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during bench.-    benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (),-    -- |Hook to run after bench command.-    postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()-  }--{-# 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,-      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,-      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  = rn',-      testHook = \_ -> ru,-      postTest = ru,-      preBench = rn',-      benchHook = \_ -> ru,-      postBench = ru-    }-    where rn  args _ = noExtraFlags args >> return emptyHookedBuildInfo-          rn' _    _ = return emptyHookedBuildInfo-          ru _ _ _ _ = return ()
− Distribution/Simple/Utils.hs 
@@ -1,1370 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Simple.Utils--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004--- License     :  BSD3---                portions Copyright (c) 2007, Galois Inc.------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ A large and somewhat miscellaneous collection of utility functions used--- throughout the rest of the Cabal lib and in other tools that use the Cabal--- lib like @cabal-install@. It has a very simple set of logging actions. It--- has low level functions for running programs, a bunch of wrappers for--- various directory and file functions that do extra logging.--module Distribution.Simple.Utils (-        cabalVersion,--        -- * logging and errors-        die,-        dieWithLocation,-        topHandler, topHandlerWith,-        warn, notice, setupMessage, info, debug,-        debugNoWrap, chattyTry,-        printRawCommandAndArgs, printRawCommandAndArgsAndEnv,--        -- * running programs-        rawSystemExit,-        rawSystemExitCode,-        rawSystemExitWithEnv,-        rawSystemStdout,-        rawSystemStdInOut,-        rawSystemIOWithEnv,-        maybeExit,-        xargs,-        findProgramLocation,-        findProgramVersion,--        -- * copying files-        smartCopySources,-        createDirectoryIfMissingVerbose,-        copyFileVerbose,-        copyDirectoryRecursiveVerbose,-        copyFiles,-        copyFileTo,--        -- * installing files-        installOrdinaryFile,-        installExecutableFile,-        installMaybeExecutableFile,-        installOrdinaryFiles,-        installExecutableFiles,-        installMaybeExecutableFiles,-        installDirectoryContents,-        copyDirectoryRecursive,--        -- * File permissions-        doesExecutableExist,-        setFileOrdinary,-        setFileExecutable,--        -- * file names-        currentDir,-        shortRelativePath,--        -- * finding files-        findFile,-        findFirstFile,-        findFileWithExtension,-        findFileWithExtension',-        findModuleFile,-        findModuleFiles,-        getDirectoryContentsRecursive,--        -- * environment variables-        isInSearchPath,-        addLibraryPath,--        -- * simple file globbing-        matchFileGlob,-        matchDirFileGlob,-        parseFileGlob,-        FileGlob(..),--        -- * modification time-        moreRecentFile,-        existsAndIsMoreRecentThan,--        -- * temp files and dirs-        TempFileOptions(..), defaultTempFileOptions,-        withTempFile, withTempFileEx,-        withTempDirectory, withTempDirectoryEx,--        -- * .cabal and .buildinfo files-        defaultPackageDesc,-        findPackageDesc,-        tryFindPackageDesc,-        defaultHookedPackageDesc,-        findHookedPackageDesc,--        -- * reading and writing files safely-        withFileContents,-        writeFileAtomic,-        rewriteFile,--        -- * Unicode-        fromUTF8,-        toUTF8,-        readUTF8File,-        withUTF8FileContents,-        writeUTF8File,-        normaliseLineEndings,--        -- * generic utils-        dropWhileEndLE,-        takeWhileEndLE,-        equating,-        comparing,-        isInfixOf,-        intercalate,-        lowercase,-        listUnion,-        listUnionRight,-        ordNub,-        ordNubRight,-        wrapText,-        wrapLine,-  ) where--import Control.Monad-    ( join, when, unless, filterM )-import Control.Concurrent.MVar-    ( newEmptyMVar, putMVar, takeMVar )-import Data.List-  ( nub, unfoldr, isPrefixOf, tails, intercalate )-import Data.Char as Char-    ( isDigit, toLower, chr, ord )-import Data.Bits-    ( Bits((.|.), (.&.), shiftL, shiftR) )-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import qualified Data.Set as Set--import System.Directory-    ( Permissions(executable), getDirectoryContents, getPermissions-    , doesDirectoryExist, doesFileExist, removeFile, findExecutable-    , getModificationTime )-import System.Environment-    ( getProgName )-import System.Exit-    ( exitWith, ExitCode(..) )-import System.FilePath-    ( normalise, (</>), (<.>)-    , getSearchPath, joinPath, takeDirectory, splitFileName-    , splitExtension, splitExtensions, splitDirectories-    , searchPathSeparator )-import System.Directory-    ( createDirectory, renameFile, removeDirectoryRecursive )-import System.IO-    ( Handle, openFile, openBinaryFile, openBinaryTempFileWithDefaultPermissions-    , IOMode(ReadMode), hSetBinaryMode-    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )-import System.IO.Error as IO.Error-    ( isDoesNotExistError, isAlreadyExistsError-    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )-import System.IO.Error-    ( ioeSetLocation, ioeGetLocation )-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.System-    ( OS (..) )-import Distribution.Version-    (Version(..))--import Control.Exception (IOException, evaluate, throwIO)-import Control.Concurrent (forkIO)-import qualified System.Process as Process-         ( CreateProcess(..), StdStream(..), proc)-import System.Process-         ( createProcess, rawSystem, runInteractiveProcess-         , showCommandForUser, waitForProcess)-import Distribution.Compat.CopyFile-         ( copyFile, copyOrdinaryFile, copyExecutableFile-         , setFileOrdinary, setFileExecutable, setDirOrdinary )-import Distribution.Compat.TempFile-         ( openTempFile, createTempDirectory )-import Distribution.Compat.Exception-         ( tryIO, catchIO, catchExit )-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-    setLocation Nothing  err = err-    setLocation (Just n) err = ioeSetLocation err (show n)--die :: String -> IO a-die msg = ioError (userError msg)--topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a-topHandlerWith cont prog = catchIO prog handle-  where-    handle ioe = do-      hFlush stdout-      pname <- getProgName-      hPutStr stderr (mesage pname)-      cont ioe-      where-        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)-        file         = case ioeGetFileName ioe of-                         Nothing   -> ""-                         Just path -> path ++ location ++ ": "-        location     = case ioeGetLocation ioe of-                         l@(n:_) | Char.isDigit n -> ':' : l-                         _                        -> ""-        detail       = ioeGetErrorString ioe--topHandler :: IO a -> IO a-topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog---- | 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---- | 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 =-  when (verbosity >= deafening) $ do-    putStrLn 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-         . map (intercalate "\n"-              . map unwords-              . wrapLine 79-              . words)-         . lines---- | Wraps a list of words to a list of lines of words of a particular width.-wrapLine :: Int -> [String] -> [[String]]-wrapLine width = wrap 0 []-  where wrap :: Int -> [String] -> [String] -> [[String]]-        wrap 0   []   (w:ws)-          | length w + 1 > width-          = wrap (length w) [w] ws-        wrap col line (w:ws)-          | col + length w + 1 > width-          = reverse line : wrap 0 [] (w:ws)-        wrap col line (w:ws)-          = let col' = col + length w + 1-             in wrap col' (w:line) ws-        wrap _ []   [] = []-        wrap _ line [] = [reverse line]---- -------------------------------------------------------------------------------- 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 =-    printRawCommandAndArgsAndEnv verbosity path args Nothing--printRawCommandAndArgsAndEnv :: Verbosity-                             -> FilePath-                             -> [String]-                             -> Maybe [(String, String)]-                             -> IO ()-printRawCommandAndArgsAndEnv verbosity path args menv- | verbosity >= deafening = do-       maybe (return ()) (putStrLn . ("Environment: " ++) . show) menv-       print (path, args)- | verbosity >= verbose   = putStrLn $ showCommandForUser path args- | otherwise              = return ()----- Exit with the same exit code 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 (Just env)-    hFlush stdout-    (_,_,_,ph) <- createProcess $-                  (Process.proc path args) { Process.env = (Just env)-#ifdef MIN_VERSION_process-#if MIN_VERSION_process(1,2,0)--- delegate_ctlc has been added in process 1.2, and we still want to be able to--- bootstrap GHC on systems not having that version-                                           , Process.delegate_ctlc = True-#endif-#endif-                                           }-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-        debug verbosity $ path ++ " returned " ++ show exitcode-        exitWith exitcode---- Closes the passed in handles before returning.-rawSystemIOWithEnv :: Verbosity-                   -> FilePath-                   -> [String]-                   -> Maybe FilePath           -- ^ New working dir or inherit-                   -> Maybe [(String, String)] -- ^ New environment or inherit-                   -> Maybe Handle  -- ^ stdin-                   -> Maybe Handle  -- ^ stdout-                   -> Maybe Handle  -- ^ stderr-                   -> IO ExitCode-rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do-    printRawCommandAndArgsAndEnv verbosity path args menv-    hFlush stdout-    (_,_,_,ph) <- createProcess $-                  (Process.proc path args) { Process.cwd           = mcwd-                                           , Process.env           = menv-                                           , Process.std_in        = mbToStd inp-                                           , Process.std_out       = mbToStd out-                                           , Process.std_err       = mbToStd err-#ifdef MIN_VERSION_process-#if MIN_VERSION_process(1,2,0)--- delegate_ctlc has been added in process 1.2, and we still want to be able to--- bootstrap GHC on systems not having that version-                                           , Process.delegate_ctlc = True-#endif-#endif-                                           }-    exitcode <- waitForProcess ph-    unless (exitcode == ExitSuccess) $ do-      debug verbosity $ path ++ " returned " ++ show exitcode-    return exitcode-  where-    mbToStd :: Maybe Handle -> Process.StdStream-    mbToStd = maybe Process.Inherit Process.UseHandle---- | 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 Nothing-                                                  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                 -- ^ Program location-                  -> [String]                 -- ^ Arguments-                  -> Maybe FilePath           -- ^ New working dir or inherit-                  -> Maybe [(String, String)] -- ^ New environment or inherit-                  -> Maybe (String, Bool)     -- ^ input text and binary mode-                  -> Bool                     -- ^ output in binary mode-                  -> IO (String, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do-  printRawCommandAndArgs verbosity path args--  Exception.bracket-     (runInteractiveProcess path args mcwd menv)-     (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)-    $ \(inh,outh,errh,pid) -> do--      -- output mode depends on what the caller wants-      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-                       ++ case input of-                            Nothing       -> ""-                            Just ("",  _) -> ""-                            Just (inp, _) -> "\nstdin input:\n" ++ inp--      return (out, err, exitcode)----- | 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----------------------------- 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--------------------- 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------------------------- 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 = createDirs (parents path0)-  | otherwise      = 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-              if isDir then return ()-                       else throwIO e-              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())-          | otherwise              -> throwIO 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---- | Install a file that may or not be executable, preserving permissions.-installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()-installMaybeExecutableFile verbosity src dest = 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 = do-  let targetFile = dir </> file-  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)-  installOrdinaryFile verbosity file targetFile---- | Common implementation of 'copyFiles', 'installOrdinaryFiles',--- 'installExecutableFiles' and 'installMaybeExecutableFiles'.-copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())-              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFilesWith doCopy verbosity targetDir srcFiles = 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 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 = copyFilesWith copyFileVerbose---- | This is like 'copyFiles' but uses 'installOrdinaryFile'.----installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles = copyFilesWith installOrdinaryFile---- | This is like 'copyFiles' but uses 'installExecutableFile'.----installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]-                          -> IO ()-installExecutableFiles = copyFilesWith installExecutableFile---- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.----installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]-                               -> IO ()-installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile---- | 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 ]---- | Recursively copy the contents of one directory to another path.-copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()-copyDirectoryRecursive verbosity srcDir destDir = 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-------------------------------------- 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---- | Advanced options for 'withTempFile' and 'withTempDirectory'.-data TempFileOptions = TempFileOptions {-  optKeepTempFiles :: Bool  -- ^ Keep temporary files?-  }--defaultTempFileOptions :: TempFileOptions-defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }---- | Use a temporary filename that doesn't already exist.----withTempFile :: FilePath    -- ^ Temp dir to create the file in-                -> String   -- ^ File name template. See 'openTempFile'.-                -> (FilePath -> Handle -> IO a) -> IO a-withTempFile tmpDir template action =-  withTempFileEx defaultTempFileOptions tmpDir template action---- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'--- argument.-withTempFileEx :: TempFileOptions-                 -> FilePath -- ^ Temp dir to create the file in-                 -> String   -- ^ File name template. See 'openTempFile'.-                 -> (FilePath -> Handle -> IO a) -> IO a-withTempFileEx opts tmpDir template action =-  Exception.bracket-    (openTempFile tmpDir template)-    (\(name, handle) -> do hClose handle-                           unless (optKeepTempFiles opts) $ 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 =-  withTempDirectoryEx verbosity defaultTempFileOptions targetDir template---- | 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 =-  Exception.bracket-    (createTempDirectory targetDir template)-    (unless (optKeepTempFiles opts) . 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 successfully or an IO exception is raised and--- the original file is left unchanged.------ On windows it is not possible to delete a file that is open by a process.--- This case will give an IO exception but the atomic property is not affected.----writeFileAtomic :: FilePath -> BS.ByteString -> IO ()-writeFileAtomic targetPath content = do-  let (targetDir, targetFile) = splitFileName targetPath-  Exception.bracketOnError-    (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")-    (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)-    (\(tmpPath, handle) -> do-        BS.hPut handle content-        hClose handle-        renameFile tmpPath targetPath)---- | 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: the file is assumed to be ASCII-encoded.-rewriteFile :: FilePath -> String -> IO ()-rewriteFile path newContent =-  flip catchIO mightNotExist $ do-    existingContent <- readFile path-    _ <- evaluate (length existingContent)-    unless (existingContent == newContent) $-      writeFileAtomic path (BS.Char8.pack newContent)-  where-    mightNotExist e | isDoesNotExistError e = writeFileAtomic path-                                              (BS.Char8.pack newContent)-                    | otherwise             = ioError e---- | The path name that represents the current directory.--- In Unix, it's @\".\"@, but this is system-specific.--- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)-currentDir :: FilePath-currentDir = "."--shortRelativePath :: FilePath -> FilePath -> FilePath-shortRelativePath from to =-    case dropCommonPrefix (splitDirectories from) (splitDirectories to) of-        (stuff, path) -> joinPath (map (const "..") stuff ++ path)-  where-    dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])-    dropCommonPrefix (x:xs) (y:ys)-        | x == y    = dropCommonPrefix xs ys-    dropCommonPrefix xs ys = (xs,ys)---- --------------------------------------------------------------- * Finding the description file--- ---------------------------------------------------------------- |Package description file (/pkgname/@.cabal@)-defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc _verbosity = tryFindPackageDesc currentDir---- |Find a package description file in the given directory.  Looks for--- @.cabal@ files.-findPackageDesc :: FilePath                    -- ^Where to look-                -> IO (Either String FilePath) -- ^<pkgname>.cabal-findPackageDesc 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-        []          -> return (Left  noDesc)-        [cabalFile] -> return (Right cabalFile)-        multiple    -> return (Left  $ multiDesc multiple)--  where-    noDesc :: String-    noDesc = "No cabal file found.\n"-             ++ "Please create a package description file <pkgname>.cabal"--    multiDesc :: [String] -> String-    multiDesc l = "Multiple cabal files found.\n"-                  ++ "Please use only one of: "-                  ++ intercalate ", " l---- |Like 'findPackageDesc', but calls 'die' in case of error.-tryFindPackageDesc :: FilePath -> IO FilePath-tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir---- |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 . BS.Char8.pack . 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 OS X-normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s---- --------------------------------------------------------------- * Common utils--- ---------------------------------------------------------------- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but--- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this--- version is that the one in "Data.List" is strict in elements, but spine-lazy,--- while this one is spine-strict but lazy in elements. That's what @LE@ stands--- for - "lazy in elements".------ Example:------ @--- > tail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1]--- *** Exception: Prelude.undefined--- > tail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1]--- [5,4,3]--- > take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined]--- [5,4,3]--- > take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined]--- *** Exception: Prelude.undefined--- @-dropWhileEndLE :: (a -> Bool) -> [a] -> [a]-dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []---- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but--- is usually faster (as well as being easier to read).-takeWhileEndLE :: (a -> Bool) -> [a] -> [a]-takeWhileEndLE p = fst . foldr go ([], False)-  where-    go x (rest, done)-      | not done && p x = (x:rest, False)-      | otherwise = (rest, True)---- | Like "Data.List.nub", but has @O(n log n)@ complexity instead of--- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's--- <http://github.com/nh2/haskell-ordnub ordnub> package.-ordNub :: (Ord a) => [a] -> [a]-ordNub l = go Set.empty l-  where-    go _ [] = []-    go s (x:xs) = if x `Set.member` s then go s xs-                                      else x : go (Set.insert x s) xs---- | Like "Data.List.union", but has @O(n log n)@ complexity instead of--- @O(n^2)@.-listUnion :: (Ord a) => [a] -> [a] -> [a]-listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)-  where-    aSet = Set.fromList a---- | A right-biased version of 'ordNub'.------ Example:------ @--- > ordNub [1,2,1]--- [1,2]--- > ordNubRight [1,2,1]--- [2,1]--- @-ordNubRight :: (Ord a) => [a] -> [a]-ordNubRight = fst . foldr go ([], Set.empty)-  where-    go x p@(l, s) = if x `Set.member` s then p-                                        else (x:l, Set.insert x s)---- | A right-biased version of 'listUnion'.------ Example:------ @--- > listUnion [1,2,3,4,3] [2,1,1]--- [1,2,3,4,3]--- > listUnionRight [1,2,3,4,3] [2,1,1]--- [4,3,2,1,1]--- @-listUnionRight :: (Ord a) => [a] -> [a] -> [a]-listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b-  where-    bSet = Set.fromList b--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)--lowercase :: String -> String-lowercase = map Char.toLower
− Distribution/System.hs 
@@ -1,215 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- 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,-  platformFromTriple-  ) where--import qualified System.Info (os, arch)-import qualified Data.Char as Char (toLower, isAlphaNum)--import Distribution.Compat.Binary (Binary)-import Data.Data (Data)-import Data.Typeable (Typeable)-import Data.Maybe (fromMaybe, listToMaybe)-import Distribution.Text (Text(..), display)-import qualified Distribution.Compat.ReadP as Parse-import GHC.Generics (Generic)-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        -- tier 1 desktop OSs-        | FreeBSD | OpenBSD | NetBSD   -- other free Unix OSs-        | DragonFly-        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs-        | HaLVM                        -- bare metal / VMs / hypervisors-        | IOS                          -- iOS-        | Ghcjs-        | OtherOS String-  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary OS----TODO: decide how to handle Android and iOS.--- They are like Linux and OSX but with some differences.--- Should they be separate from Linux/OS X, or a subtype?--- e.g. should we have os(linux) && os(android) true simultaneously?--knownOSs :: [OS]-knownOSs = [Linux, Windows, OSX-           ,FreeBSD, OpenBSD, NetBSD, DragonFly-           ,Solaris, AIX, HPUX, IRIX-           ,HaLVM-           ,IOS-           ,Ghcjs]--osAliases :: ClassificationStrictness -> OS -> [String]-osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"]-osAliases Compat     Windows = ["mingw32", "win32"]-osAliases _          OSX     = ["darwin"]-osAliases Permissive FreeBSD = ["kfreebsdgnu"]-osAliases Compat     FreeBSD = ["kfreebsdgnu"]-osAliases Permissive Solaris = ["solaris2"]-osAliases Compat     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 =-  fromMaybe (OtherOS s) $ lookup (lowercase s) osMap-  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-          | JavaScript-          | OtherArch String-  deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)--instance Binary Arch--knownArches :: [Arch]-knownArches = [I386, X86_64, PPC, PPC64, Sparc-              ,Arm, Mips, SH-              ,IA64, S390-              ,Alpha, Hppa, Rs6000-              ,M68k, Vax-              ,JavaScript]--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 =-  fromMaybe (OtherArch s) $ lookup (lowercase s) archMap-  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, Generic, Ord, Show, Read, Typeable, Data)--instance Binary Platform--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)---- | The platform Cabal was compiled on. In most cases,--- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're--- targeting).-buildPlatform :: Platform-buildPlatform = Platform buildArch buildOS---- Utils:--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--platformFromTriple :: String -> Maybe Platform-platformFromTriple triple =-  fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple)-  where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_')-        parseTriple = do-          arch <- fmap (classifyArch Strict) parseWord-          _ <- Parse.char '-'-          _ <- parseWord -- Skip vendor-          _ <- Parse.char '-'-          os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like-                                               -- 'nto-qnx'-          return $ Platform arch os
− Distribution/TestSuite.hs 
@@ -1,96 +0,0 @@--------------------------------------------------------------------------------- |--- 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--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 }
− 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/Utils/NubList.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Utils.NubList-    ( NubList    -- opaque-    , toNubList  -- smart construtor-    , fromNubList-    , overNubList--    , NubListR-    , toNubListR-    , fromNubListR-    , overNubListR-    ) where--import Distribution.Compat.Binary-#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif--import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight)--import qualified Text.Read as R---- | NubList : A de-duplicated list that maintains the original order.-newtype NubList a =-    NubList { fromNubList :: [a] }-    deriving Eq---- NubList assumes that nub retains the list order while removing duplicate--- elements (keeping the first occurence). 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 satistfy 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 (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 :: (Ord a, Read a) => ([a] -> l a) -> R.ReadPrec (l a)-readNubList toList = R.parens . R.prec 10 $ fmap toList 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---- | 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 (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
− Distribution/Verbosity.hs 
@@ -1,89 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Distribution.Verbosity--- Copyright   :  Ian Lynagh 2007--- License     :  BSD3------ 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.--module Distribution.Verbosity (-  -- * Verbosity-  Verbosity,-  silent, normal, verbose, deafening,-  moreVerbose, lessVerbose,-  intToVerbosity, flagToVerbosity,-  showForCabal, showForGHC- ) where--import Distribution.Compat.Binary (Binary)-import Data.List (elemIndex)-import Distribution.ReadE-import GHC.Generics--data Verbosity = Silent | Normal | Verbose | Deafening-    deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded)--instance Binary Verbosity---- 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,777 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-#if __GLASGOW_HASKELL__ < 707-{-# LANGUAGE StandaloneDeriving #-}-#endif---- Hack approach to support bootstrapping--- Assume binary <0.8 when MIN_VERSION_binary macro is not available.--- Starting with GHC>=8.0, compiler will hopefully provide this macros too.--- https://ghc.haskell.org/trac/ghc/ticket/10970------ Otherwise, one can specify -DMIN_VERSION_binary_0_8_0=1, when bootstrapping--- with binary >=0.8.0.0-#ifdef MIN_VERSION_binary-#define MIN_VERSION_binary_0_8_0 MIN_VERSION_binary(0,8,0)-#else-#ifndef MIN_VERSION_binary_0_8_0-#define MIN_VERSION_binary_0_8_0 0-#endif-#endif--#if !MIN_VERSION_binary_0_8_0-{-# OPTIONS_GHC -fno-warn-orphans #-}-#endif---------------------------------------------------------------------------------- |--- Module      :  Distribution.Version--- Copyright   :  Isaac Jones, Simon Marlow 2003-2004---                Duncan Coutts 2008--- License     :  BSD3------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Exports the 'Version' type along with a parser and pretty printer. A version--- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data--- types. Version ranges are like @\">= 1.2 && < 2\"@.--module Distribution.Version (-  -- * Package versions-  Version(..),--  -- * Version ranges-  VersionRange(..),--  -- ** Constructing-  anyVersion, noVersion,-  thisVersion, notThisVersion,-  laterVersion, earlierVersion,-  orLaterVersion, orEarlierVersion,-  unionVersionRanges, intersectVersionRanges,-  withinVersion,-  betweenVersionsInclusive,--  -- ** Inspection-  withinRange,-  isAnyVersion,-  isNoVersion,-  isSpecificVersion,-  simplifyVersionRange,-  foldVersionRange,-  foldVersionRange',--  -- ** Modification-  removeUpperBound,--  -- * 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 Distribution.Compat.Binary ( Binary(..) )-import Data.Data        ( Data )-import Data.Typeable    ( Typeable )-import Data.Version     ( Version(..) )-import GHC.Generics     ( Generic )--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 (Data, Eq, Generic, Read, Show, Typeable)--instance Binary VersionRange--#if __GLASGOW_HASKELL__ < 707--- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data"-deriving instance Data Version-#endif--#if !(MIN_VERSION_binary_0_8_0)--- Deriving this instance from Generic gives trouble on GHC 7.2 because the--- Generic instance has to be standalone-derived. So, we hand-roll our own.--- We can't use a generic Binary instance on later versions because we must--- maintain compatibility between compiler versions.-instance Binary Version where-    get = do-        br <- get-        tags <- get-        return $ Version br tags-    put (Version br tags) = put br >> put tags-#endif--{-# 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 noVersion = 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" #-}---- | Given a version range, remove the highest upper bound. Example: @(>= 1 && <--- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@.-removeUpperBound :: VersionRange -> VersionRange-removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals-  where-    relaxLastInterval (VersionIntervals intervals) =-      VersionIntervals (relaxLastInterval' intervals)--    relaxLastInterval' []      = []-    relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]-    relaxLastInterval' (i:is)  = i : relaxLastInterval' is---- | Fold over the basic syntactic structure of a 'VersionRange'.------ This provides a syntactic view of the expression defining the version range.--- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented--- in terms of the other basic syntax.------ For a semantic view use 'asVersionIntervals'.----foldVersionRange :: a                         -- ^ @\"-any\"@ version-                 -> (Version -> a)            -- ^ @\"== v\"@-                 -> (Version -> a)            -- ^ @\"> v\"@-                 -> (Version -> a)            -- ^ @\"< v\"@-                 -> (a -> a -> a)             -- ^ @\"_ || _\"@ union-                 -> (a -> a -> a)             -- ^ @\"_ && _\"@ intersection-                 -> VersionRange -> a-foldVersionRange 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 intervals 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-                              : parseNoVersion-                              : parseWildcardRange-                              : map parseRangeOp rangeOps-        parseAnyVersion    = Parse.string "-any" >> return AnyVersion-        parseNoVersion     = Parse.string "-none" >> return noVersion--        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,8 +1,8 @@-Copyright (c) 2003-2014, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson, Ian Lynagh,-                         Duncan Coutts, Thomas Schilling,-                         Johan Tibell, Mikhail Glushenkov+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,795 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      :  Language.Haskell.Extension--- Copyright   :  Isaac Jones 2003-2004--- License     :  BSD3------ Maintainer  :  libraries@haskell.org--- Portability :  portable------ Haskell language dialects and extensions--module Language.Haskell.Extension (-        Language(..),-        knownLanguages,--        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), (!))-import Distribution.Compat.Binary (Binary)-import Data.Data (Data)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)---- --------------------------------------------------------------- * 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 (Generic, Show, Read, Eq, Typeable, Data)--instance Binary Language--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, LHC, UHC, HaskellSuite)------ | This represents language extensions beyond a base 'Language' definition--- (such as 'Haskell98') that are supported by some implementations, usually--- in some special mode.------ Where applicable, references are given to an implementation's--- official documentation.--data Extension =-  -- | Enable a known extension-    EnableExtension KnownExtension--  -- | Disable a known extension-  | DisableExtension KnownExtension--  -- | An unknown extension, identified by the name of its @LANGUAGE@-  -- pragma.-  | UnknownExtension String--  deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)--instance Binary Extension--data KnownExtension =--  -- | Allow overlapping class instances, provided there is a unique-  -- most specific instance for each use.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>-    OverlappingInstances--  -- | Ignore structural rules guaranteeing the termination of class-  -- instance resolution.  Termination is guaranteed by a fixed-depth-  -- recursion stack, and compilation may fail if this depth is-  -- exceeded.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#undecidable-instances>-  | UndecidableInstances--  -- | Implies 'OverlappingInstances'.  Allow the implementation to-  -- choose an instance even when it is possible that further-  -- instantiation of types will lead to a more specific instance-  -- being applicable.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>-  | IncoherentInstances--  -- | /(deprecated)/ Allow recursive bindings in @do@ blocks, using the @rec@-  -- keyword. See also 'RecursiveDo'.-  | DoRec--  -- | Allow recursive bindings using @mdo@, a variant of @do@.-  -- @DoRec@ provides a different, preferred syntax.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#recursive-do-notation>-  | RecursiveDo--  -- | Provide syntax for writing list comprehensions which iterate-  -- over several lists together, like the 'zipWith' family of-  -- functions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#parallel-list-comprehensions>-  | ParallelListComp--  -- | Allow multiple parameters in a type class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#multi-param-type-classes>-  | MultiParamTypeClasses--  -- | Enable the dreaded monomorphism restriction.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html>-  | MonomorphismRestriction--  -- | Allow a specification attached to a multi-parameter type class-  -- which indicates that some parameters are entirely determined by-  -- others. The implementation will check that this property holds-  -- for the declared instances, and will use this property to reduce-  -- ambiguity in instance resolution.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#functional-dependencies>-  | FunctionalDependencies--  -- | Like 'RankNTypes' but does not allow a higher-rank type to-  -- itself appear on the left of a function arrow.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>-  | Rank2Types--  -- | Allow a universally-quantified type to occur on the left of a-  -- function arrow.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>-  | RankNTypes--  -- | Allow data constructors to have polymorphic arguments.  Unlike-  -- 'RankNTypes', does not allow this for ordinary functions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>-  | PolymorphicComponents--  -- | Allow existentially-quantified data constructors.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#existential-quantification>-  | ExistentialQuantification--  -- | Cause a type variable in a signature, which has an explicit-  -- @forall@ quantifier, to scope over the definition of the-  -- accompanying value declaration.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#scoped-type-variables>-  | ScopedTypeVariables--  -- | Deprecated, use 'ScopedTypeVariables' instead.-  | PatternSignatures--  -- | Enable implicit function parameters with dynamic scope.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#implicit-parameters>-  | ImplicitParams--  -- | Relax some restrictions on the form of the context of a type-  -- signature.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#flexible-contexts>-  | FlexibleContexts--  -- | Relax some restrictions on the form of the context of an-  -- instance declaration.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-rules>-  | FlexibleInstances--  -- | Allow data type declarations with no constructors.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#nullary-types>-  | EmptyDataDecls--  -- | Run the C preprocessor on Haskell source code.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#c-pre-processor>-  | CPP--  -- | Allow an explicit kind signature giving the kind of types over-  -- which a type variable ranges.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#kinding>-  | KindSignatures--  -- | Enable a form of pattern which forces evaluation before an-  -- attempted match, and a form of strict @let@/@where@ binding.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bang-patterns.html>-  | BangPatterns--  -- | Allow type synonyms in instance heads.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#flexible-instance-head>-  | TypeSynonymInstances--  -- | Enable Template Haskell, a system for compile-time-  -- metaprogramming.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html>-  | TemplateHaskell--  -- | Enable the Foreign Function Interface.  In GHC, implements the-  -- standard Haskell 98 Foreign Function Interface Addendum, plus-  -- some GHC-specific extensions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html>-  | ForeignFunctionInterface--  -- | Enable arrow notation.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/arrow-notation.html>-  | Arrows--  -- | /(deprecated)/ Enable generic type classes, with default instances defined in-  -- terms of the algebraic structure of a type.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/generic-classes.html>-  | Generics--  -- | Enable the implicit importing of the module "Prelude".  When-  -- disabled, when desugaring certain built-in syntax into ordinary-  -- identifiers, use whatever is in scope rather than the "Prelude"-  -- -- version.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>-  | ImplicitPrelude--  -- | Enable syntax for implicitly binding local names corresponding-  -- to the field names of a record.  Puns bind specific names, unlike-  -- 'RecordWildCards'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-puns>-  | NamedFieldPuns--  -- | Enable a form of guard which matches a pattern and binds-  -- variables.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#pattern-guards>-  | PatternGuards--  -- | Allow a type declared with @newtype@ to use @deriving@ for any-  -- class with an instance for the underlying type.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#newtype-deriving>-  | GeneralizedNewtypeDeriving--  -- | Enable the \"Trex\" extensible records system.-  ---  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/hugs-only.html#TREX>-  | ExtensibleRecords--  -- | Enable type synonyms which are transparent in some definitions-  -- and opaque elsewhere, as a way of implementing abstract-  -- datatypes.-  ---  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/restricted-synonyms.html>-  | RestrictedTypeSynonyms--  -- | Enable an alternate syntax for string literals,-  -- with string templating.-  ---  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/here-documents.html>-  | HereDocuments--  -- | Allow the character @#@ as a postfix modifier on identifiers.-  -- Also enables literal syntax for unboxed values.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#magic-hash>-  | MagicHash--  -- | Allow data types and type synonyms which are indexed by types,-  -- i.e. ad-hoc polymorphism for types.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-families.html>-  | TypeFamilies--  -- | Allow a standalone declaration which invokes the type class-  -- @deriving@ mechanism.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#stand-alone-deriving>-  | StandaloneDeriving--  -- | Allow certain Unicode characters to stand for certain ASCII-  -- character sequences, e.g. keywords and punctuation.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#unicode-syntax>-  | UnicodeSyntax--  -- | Allow the use of unboxed types as foreign types, e.g. in-  -- @foreign import@ and @foreign export@.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#id681687>-  | UnliftedFFITypes--  -- | Enable interruptible FFI.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-interruptible>-  | InterruptibleFFI--  -- | Allow use of CAPI FFI calling convention (@foreign import capi@).-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-capi>-  | CApiFFI--  -- | Defer validity checking of types until after expanding type-  -- synonyms, relaxing the constraints on how synonyms may be used.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#type-synonyms>-  | LiberalTypeSynonyms--  -- | Allow the name of a type constructor, type class, or type-  -- variable to be an infix operator.-  | TypeOperators--  -- | Enable syntax for implicitly binding local names corresponding-  -- to the field names of a record.  A wildcard binds all unmentioned-  -- names, unlike 'NamedFieldPuns'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-wildcards>-  | RecordWildCards--  -- | Deprecated, use 'NamedFieldPuns' instead.-  | RecordPuns--  -- | Allow a record field name to be disambiguated by the type of-  -- the record it's in.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#disambiguate-fields>-  | DisambiguateRecordFields--  -- | Enable traditional record syntax (as supported by Haskell 98)-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#traditional-record-syntax>-  | TraditionalRecordSyntax--  -- | Enable overloading of string literals using a type class, much-  -- like integer literals.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings>-  | OverloadedStrings--  -- | Enable generalized algebraic data types, in which type-  -- variables may be instantiated on a per-constructor basis. Implies-  -- 'GADTSyntax'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt>-  | GADTs--  -- | Enable GADT syntax for declaring ordinary algebraic datatypes.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt-style>-  | GADTSyntax--  -- | Make pattern bindings monomorphic.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html#id630981>-  | MonoPatBinds--  -- | Relax the requirements on mutually-recursive polymorphic-  -- functions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#typing-binds>-  | RelaxedPolyRec--  -- | Allow default instantiation of polymorphic types in more-  -- situations.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/interactive-evaluation.html#extended-default-rules>-  | ExtendedDefaultRules--  -- | Enable unboxed tuples.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/primitives.html#unboxed-tuples>-  | UnboxedTuples--  -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and-  -- 'Data.Generics.Data'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>-  | DeriveDataTypeable--  -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>-  | DeriveGeneric--  -- | Enable support for default signatures.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-default-signatures>-  | DefaultSignatures--  -- | Allow type signatures to be specified in instance declarations.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-sigs>-  | InstanceSigs--  -- | Allow a class method's type to place additional constraints on-  -- a class type variable.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-method-types>-  | ConstrainedClassMethods--  -- | Allow imports to be qualified by the package name the module is-  -- intended to be imported from, e.g.-  ---  -- > import "network" Network.Socket-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-imports>-  | PackageImports--  -- | /(deprecated)/ Allow a type variable to be instantiated at a-  -- polymorphic type.-  ---  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/other-type-extensions.html#impredicative-polymorphism>-  | ImpredicativeTypes--  -- | /(deprecated)/ Change the syntax for qualified infix operators.-  ---  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/syntax-extns.html#new-qualified-operators>-  | NewQualifiedOperators--  -- | Relax the interpretation of left operator sections to allow-  -- unary postfix operators.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#postfix-operators>-  | PostfixOperators--  -- | Enable quasi-quotation, a mechanism for defining new concrete-  -- syntax for expressions and patterns.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-quasiquotation>-  | QuasiQuotes--  -- | Enable generalized list comprehensions, supporting operations-  -- such as sorting and grouping.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#generalised-list-comprehensions>-  | TransformListComp--  -- | Enable monad comprehensions, which generalise the list-  -- comprehension syntax to work for any monad.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#monad-comprehensions>-  | MonadComprehensions--  -- | Enable view patterns, which match a value by applying a-  -- function and matching on the result.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#view-patterns>-  | ViewPatterns--  -- | Allow concrete XML syntax to be used in expressions and patterns,-  -- as per the Haskell Server Pages extension language:-  -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are-  -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"-  -- by Niklas Broberg, from Haskell Workshop '05.-  | XmlSyntax--  -- | Allow regular pattern matching over lists, as discussed in the-  -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre-  -- and Josef Svenningsson, from ICFP '04.-  | RegularPatterns--  -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into-  -- @\x -> (x, True)@.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#tuple-sections>-  | TupleSections--  -- | Allow GHC primops, written in C--, to be imported into a Haskell-  -- file.-  | GHCForeignImportPrim--  -- | Support for patterns of the form @n + k@, where @k@ is an-  -- integer literal.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#n-k-patterns>-  | NPlusKPatterns--  -- | Improve the layout rule when @if@ expressions are used in a @do@-  -- block.-  | DoAndIfThenElse--  -- | Enable support for multi-way @if@-expressions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#multi-way-if>-  | MultiWayIf--  -- | Enable support lambda-@case@ expressions.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#lambda-case>-  | LambdaCase--  -- | Makes much of the Haskell sugar be desugared into calls to the-  -- function with a particular name that is in scope.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>-  | RebindableSyntax--  -- | Make @forall@ a keyword in types, which can be used to give the-  -- generalisation explicitly.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#explicit-foralls>-  | ExplicitForAll--  -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in-  -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#datatype-contexts>-  | DatatypeContexts--  -- | Local (@let@ and @where@) bindings are monomorphic.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#mono-local-binds>-  | MonoLocalBinds--  -- | Enable @deriving@ for the 'Data.Functor.Functor' class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>-  | DeriveFunctor--  -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>-  | DeriveTraversable--  -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>-  | DeriveFoldable--  -- | Enable non-decreasing indentation for @do@ blocks.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bugs-and-infelicities.html#infelicities-syntax>-  | NondecreasingIndentation--  -- | Allow imports to be qualified with a safe keyword that requires-  -- the imported module be trusted as according to the Safe Haskell-  -- definition of trust.-  ---  -- > import safe Network.Socket-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-imports>-  | SafeImports--  -- | Compile a module in the Safe, Safe Haskell mode -- a restricted-  -- form of the Haskell language to ensure type safety.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>-  | Safe--  -- | Compile a module in the Trustworthy, Safe Haskell mode -- no-  -- restrictions apply but the module is marked as trusted as long as-  -- the package the module resides in is trusted.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>-  | Trustworthy--  -- | Compile a module in the Unsafe, Safe Haskell mode so that-  -- modules compiled using Safe, Safe Haskell mode can't import it.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>-  | Unsafe--  -- | Allow type class/implicit parameter/equality constraints to be-  -- used as types with the special kind constraint.  Also generalise-  -- the @(ctxt => ty)@ syntax so that any type of kind constraint can-  -- occur before the arrow.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/constraint-kind.html>-  | ConstraintKinds--  -- | Enable kind polymorphism.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/kind-polymorphism.html>-  | PolyKinds--  -- | Enable datatype promotion.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/promotion.html>-  | DataKinds--  -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.-  ---  -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>-  | ParallelArrays--  -- | Enable explicit role annotations, like in (@type role Foo representational representational@).-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/roles.html>-  | RoleAnnotations--  -- | Enable overloading of list literals, arithmetic sequences and-  -- list patterns using the 'IsList' type class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-lists>-  | OverloadedLists--  -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#empty-case>-  | EmptyCase--  -- | Triggers the generation of derived 'Typeable' instances for every-  -- datatype and type class declaration.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#auto-derive-typeable>-  | AutoDeriveTypeable--  -- | Desugars negative literals directly (without using negate).-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#negative-literals>-  | NegativeLiterals--  -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#binary-literals>-  | BinaryLiterals--  -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#num-decimals>-  | NumDecimals--  -- | Enable support for type classes with no type parameter.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#nullary-type-classes>-  | NullaryTypeClasses--  -- | Enable explicit namespaces in module import/export lists.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#explicit-namespaces>-  | ExplicitNamespaces--  -- | Allow the user to write ambiguous types, and the type inference engine to infer them.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#ambiguity>-  | AllowAmbiguousTypes--  -- | Enable @foreign import javascript@.-  | JavaScriptFFI--  -- | Allow giving names to and abstracting over patterns.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#pattern-synonyms>-  | PatternSynonyms--  -- | Allow anonymous placeholders (underscore) inside type signatures.  The-  -- type inference engine will generate a message describing the type inferred-  -- at the hole's location.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#partial-type-signatures>-  | PartialTypeSignatures--  -- | Allow named placeholders written with a leading underscore inside type-  -- signatures.  Wildcards with the same name unify to the same type.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#named-wildcards>-  | NamedWildCards--  -- | Enable @deriving@ for any class.-  ---  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#derive-any-class>-  | DeriveAnyClass--  deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)--instance Binary KnownExtension--{-# 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 recommend aliases that cannot be used with older--- compilers, perhaps by adding support in Cabal to translate the new--- name to the old one for older compilers. Otherwise we are in danger--- of the scenario in ticket #689.--instance 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.md view
@@ -6,119 +6,17 @@ If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. -[cabal-install]: ../cabal-install/README.md--Installing the Cabal library-============================--If you already have the `cabal` program------------------------------------------In this case run:--    $ cabal install--However, if you do not have an existing version of the `cabal` program,-you first must install the Cabal library. To avoid this bootstrapping-problem, you can install the Cabal library directly as described below.---Installing as a user (no root or administrator access)---------------------------------------------------------    ghc -threaded --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 or Administrator--------------------------------------    ghc -threaded --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.---Using older versions of GHC and Cabal-======================================--It is recommended that you leave any pre-existing version of Cabal-installed. In particular, it is *essential* you keep the version that-came with GHC itself, since other installed packages require it (for-instance, the "ghc" API package).--Prior to GHC 6.4.2, however, GHC did not 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 should probably remove it by running:--    $ ghc-pkg unregister Cabal--or, if you had Cabal installed only for your user account, run:--    $ ghc-pkg unregister Cabal --user--The `filepath` dependency-=========================--Cabal uses the [filepath] package, so it must be installed first.-GHC version 6.6.1 and later come with `filepath`, however, earlier-versions do not by default. If you do not already have `filepath`,-you need to install it. You can use any existing version of Cabal to do-that. If you have neither Cabal nor `filepath`, 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 that you can install Cabal with the normal-method.--[filepath]: http://hackage.haskell.org/package/filepath+[cabal-install]: ../cabal-install  More information ================ -Please see the [Cabal web site] for the [user guide] and [API+Please see the [Cabal web site], the [user guide] and the [API documentation]. There is additional information available on the [development wiki].  [user guide]:        http://www.haskell.org/cabal/users-guide-[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html+[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html [development wiki]:  https://github.com/haskell/cabal/wiki  @@ -136,8 +34,8 @@ [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a-problem the bug is for you. Subscribe to the issues's notifications to-discussed requirements and keep informed on progress. For feature+problem the bug is for you. Subscribe to the issue's notifications to+discuss requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature. @@ -155,21 +53,10 @@ Credits ======= -Cabal developers (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+See the `AUTHORS` file. -Cabal specification authors:+Authors of the [original Cabal+specification](https://www.haskell.org/cabal/proposal/pkg-spec.pdf):  - Isaac Jones - Simon Marlow
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,481 +0,0 @@-1.22.8.0 Ryan Thomas <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 <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-	* Relax upper bound to allow upcoming binary-0.8--1.22.5.0-	* 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 <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 <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 <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 <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 enviroments.-	* hpc: support mutliple "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.1 Johan Tibell <johan.tibell@gmail.com> May 2014-	* Fix streaming test output.--1.20.0.0 Johan Tibell <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 <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-	* 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 <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.
− doc/developing-packages.markdown 
@@ -1,2146 +0,0 @@-% Cabal User Guide: Developing Cabal packages---# Quickstart #---Lets assume we have created a project directory and already have a-Haskell module or two.--Every project needs a name, we'll call this example "proglet".--~~~~~~~~~~~-$ cd proglet/-$ ls-Proglet.hs-~~~~~~~~~~~--It is assumed that (apart from external dependencies) all the files that-make up a package live under a common project root directory. This-simple example has all the project files in one directory, but most-packages will use one or more subdirectories.--To turn this into a Cabal package we need two extra files in the-project's root directory:-- * `proglet.cabal`: containing package metadata and build information.-- * `Setup.hs`: usually containing a few standardized lines of code, but-   can be customized if necessary.--We can create both files manually or we can use `cabal init` to create-them for us.--### Using "cabal init" ###--The `cabal init` command is interactive. It asks us a number of-questions starting with the package name and version.--~~~~~~~~~~-$ cabal init-Package name [default "proglet"]?-Package version [default "0.1"]?-...-~~~~~~~~~~--It also asks questions about various other bits of package metadata. For-a package that you never intend to distribute to others, these fields can-be left blank.--One of the important questions is whether the package contains a library-or an executable. Libraries are collections of Haskell modules that can-be re-used by other Haskell libraries and programs, while executables-are standalone programs.--~~~~~~~~~~-What does the package build:-   1) Library-   2) Executable-Your choice?-~~~~~~~~~~--For the moment these are the only choices. For more complex packages-(e.g. a library and multiple executables or test suites) the `.cabal`-file can be edited afterwards.--Finally, `cabal init` creates the initial `proglet.cabal` and `Setup.hs`-files, and depending on your choice of license, a `LICENSE` file as well.--~~~~~~~~~~-Generating LICENSE...-Generating Setup.hs...-Generating proglet.cabal...--You may want to edit the .cabal file and add a Description field.-~~~~~~~~~~--As this stage the `proglet.cabal` is not quite complete and before you-are able to build the package you will need to edit the file and add-some build information about the library or executable.--### Editing the .cabal file ###--Load up the `.cabal` file in a text editor. The first part of the-`.cabal` file has the package metadata and towards the end of the file-you will find the `executable` or `library` section.--You will see that the fields that have yet to be filled in are commented-out. Cabal files use "`--`" Haskell-style comment syntax. (Note that-comments are only allowed on lines on their own. Trailing comments on-other lines are not allowed because they could be confused with program-options.)--If you selected earlier to create a library package then your `.cabal`-file will have a section that looks like this:--~~~~~~~~~~~~~~~~~-library-  exposed-modules:     Proglet-  -- other-modules:-  -- build-depends:-~~~~~~~~~~~~~~~~~--Alternatively, if you selected an executable then there will be a-section like:--~~~~~~~~~~~~~~~~~-executable proglet-  -- main-is:-  -- other-modules:-  -- build-depends:-~~~~~~~~~~~~~~~~~--The build information fields listed (but commented out) are just the few-most important and common fields. There are many others that are covered-later in this chapter.--Most of the build information fields are the same between libraries and-executables. The difference is that libraries have a number of "exposed"-modules that make up the public interface of the library, while-executables have a file containing a `Main` module.--The name of a library always matches the name of the package, so it is-not specified in the library section. Executables often follow the name-of the package too, but this is not required and the name is given-explicitly.--### Modules included in the package ###--For a library, `cabal init` looks in the project directory for files-that look like Haskell modules and adds all the modules to the-`exposed-modules` field. For modules that do not form part of your-package's public interface, you can move those modules to the-`other-modules` field. Either way, all modules in the library need to be-listed.--For an executable, `cabal init` does not try to guess which file-contains your program's `Main` module. You will need to fill in the-`main-is` field with the file name of your program's `Main` module-(including `.hs` or `.lhs` extension). Other modules included in the-executable should be listed in the `other-modules` field.--### Modules imported from other packages ###--While your library or executable may include a number of modules, it-almost certainly also imports a number of external modules from the-standard libraries or other pre-packaged libraries. (These other-libraries are of course just Cabal packages that contain a library.)--You have to list all of the library packages that your library or-executable imports modules from. Or to put it another way: you have to-list all the other packages that your package depends on.--For example, suppose the example `Proglet` module imports the module-`Data.Map`. The `Data.Map` module comes from the `containers` package,-so we must list it:--~~~~~~~~~~~~~~~~~-library-  exposed-modules:     Proglet-  other-modules:-  build-depends:       containers, base == 4.*-~~~~~~~~~~~~~~~~~--In addition, almost every package also depends on the `base` library-package because it exports the standard `Prelude` module plus other-basic modules like `Data.List`.--You will notice that we have listed `base == 4.*`. This gives a-constraint on the version of the base package that our package will work-with. The most common kinds of constraints are:-- * `pkgname >= n`- * `pkgname >= n && < m`- * `pkgname == n.*`--The last is just shorthand, for example `base == 4.*` means exactly the-same thing as `base >= 4 && < 5`.--### Building the package ###--For simple packages that's it! We can now try configuring and building-the package:--~~~~~~~~~~~~~~~~-cabal configure-cabal build-~~~~~~~~~~~~~~~~--Assuming those two steps worked then you can also install the package:--~~~~~~~~~~~~~~~~-cabal install-~~~~~~~~~~~~~~~~--For libraries this makes them available for use in GHCi or to be used by-other packages. For executables it installs the program so that you can-run it (though you may first need to adjust your system's `$PATH`).--### Next steps ###--What we have covered so far should be enough for very simple packages-that you use on your own system.--The next few sections cover more details needed for more complex-packages and details needed for distributing packages to other people.--The previous chapter covers building and installing packages -- your own-packages or ones developed by other people.---# Package concepts #--Before diving into the details of writing packages it helps to-understand a bit about packages in the Haskell world and the particular-approach that Cabal takes.--### The point of packages ###--Packages are a mechanism for organising and distributing code. Packages-are particularly suited for "programming in the large", that is building-big systems by using and re-using code written by different people at-different times.--People organise code into packages based on functionality and-dependencies. Social factors are also important: most packages have a-single author, or a relatively small team of authors.--Packages are also used for distribution: the idea is that a package can-be created in one place and be moved to a different computer and be-usable in that different environment. There are a surprising number of-details that have to be got right for this to work, and a good package-system helps to simply this process and make it reliable.--Packages come in two main flavours: libraries of reusable code, and-complete programs. Libraries present a code interface, an API, while-programs can be run directly. In the Haskell world, library packages-expose a set of Haskell modules as their public interface. Cabal-packages can contain a library or executables or both.--Some programming languages have packages as a builtin language concept.-For example in Java, a package provides a local namespace for types and-other definitions. In the Haskell world, packages are not a part of the-language itself. Haskell programs consist of a number of modules, and-packages just provide a way to partition the modules into sets of-related functionality. Thus the choice of module names in Haskell is-still important, even when using packages.--### Package names and versions ###--All packages have a name, e.g. "HUnit". Package names are assumed to be-unique. Cabal package names can use letters, numbers and hyphens, but-not spaces. The namespace for Cabal packages is flat, not hierarchical.--Packages also have a version, e.g "1.1". This matches the typical way in-which packages are developed. Strictly speaking, each version of a-package is independent, but usually they are very similar. Cabal package-versions follow the conventional numeric style, consisting of a sequence-of digits such as "1.0.1" or "2.0". There are a range of common-conventions for "versioning" packages, that is giving some meaning to-the version number in terms of changes in the package. Section [TODO]-has some tips on package versioning.--The combination of package name and version is called the _package ID_-and is written with a hyphen to separate the name and version, e.g.-"HUnit-1.1".--For Cabal packages, the combination of the package name and version-_uniquely_ identifies each package. Or to put it another way: two-packages with the same name and version are considered to _be_ the same.--Strictly speaking, the package ID only identifies each Cabal _source_-package; the same Cabal source package can be configured and built in-different ways. There is a separate installed package ID that uniquely-identifies each installed package instance. Most of the time however,-users need not be aware of this detail.--### Kinds of package: Cabal vs GHC vs system ###--It can be slightly confusing at first because there are various-different notions of package floating around. Fortunately the details-are not very complicated.--Cabal packages-:   Cabal packages are really source packages. That is they contain-    Haskell (and sometimes C) source code.--    Cabal packages can be compiled to produce GHC packages. They can-    also be translated into operating system packages.--GHC packages-:   This is GHC's view on packages. GHC only cares about library-    packages, not executables. Library packages have to be registered-    with GHC for them to be available in GHCi or to be used when-    compiling other programs or packages.--    The low-level tool `ghc-pkg` is used to register GHC packages and to-    get information on what packages are currently registered.--    You never need to make GHC packages manually. When you build and-    install a Cabal package containing a library then it gets registered-    with GHC automatically.--    Haskell implementations other than GHC have essentially the same-    concept of registered packages. For the most part, Cabal hides the-    slight differences.--Operating system packages-:   On operating systems like Linux and Mac OS X, the system has a-    specific notion of a package and there are tools for installing and-    managing packages.--    The Cabal package format is designed to allow Cabal packages to be-    translated, mostly-automatically, into operating system packages.-    They are usually translated 1:1, that is a single Cabal package-    becomes a single system package.--    It is also possible to make Windows installers from Cabal packages,-    though this is typically done for a program together with all of its-    library dependencies, rather than packaging each library separately.---### Unit of distribution ###--The Cabal package is the unit of distribution. What this means is that-each Cabal package can be distributed on its own in source or binary-form. Of course there may dependencies between packages, but there is-usually a degree of flexibility in which versions of packages can work-together so distributing them independently makes sense.--It is perhaps easiest to see what being ``the unit of distribution''-means by contrast to an alternative approach. Many projects are made up-of several interdependent packages and during development these might-all be kept under one common directory tree and be built and tested-together. When it comes to distribution however, rather than-distributing them all together in a single tarball, it is required that-they each be distributed independently in their own tarballs.--Cabal's approach is to say that if you can specify a dependency on a-package then that package should be able to be distributed-independently. Or to put it the other way round, if you want to-distribute it as a single unit, then it should be a single package.---### Explicit dependencies and automatic package management ###--Cabal takes the approach that all packages dependencies are specified-explicitly and specified in a declarative way. The point is to enable-automatic package management. This means tools like `cabal` can resolve-dependencies and install a package plus all of its dependencies-automatically. Alternatively, it is possible to mechanically (or mostly-mechanically) translate Cabal packages into system packages and let the-system package manager install dependencies automatically.--It is important to track dependencies accurately so that packages can-reliably be moved from one system to another system and still be able to-build it there. Cabal is therefore relatively strict about specifying-dependencies. For example Cabal's default build system will not even let-code build if it tries to import a module from a package that isn't-listed in the `.cabal` file, even if that package is actually installed.-This helps to ensure that there are no "untracked dependencies" that-could cause the code to fail to build on some other system.--The explicit dependency approach is in contrast to the traditional-"./configure" approach where instead of specifying dependencies-declaratively, the `./configure` script checks if the dependencies are-present on the system. Some manual work is required to transform a-`./configure` based package into a Linux distribution package (or-similar). This conversion work is usually done by people other than the-package author(s). The practical effect of this is that only the most-popular packages will benefit from automatic package management. Instead,-Cabal forces the original author to specify the dependencies but the-advantage is that every package can benefit from automatic package-management.--The "./configure" approach tends to encourage packages that adapt-themselves to the environment in which they are built, for example by-disabling optional features so that they can continue to work when a-particular dependency is not available. This approach makes sense in a-world where installing additional dependencies is a tiresome manual-process and so minimising dependencies is important. The automatic-package management view is that packages should just declare what they-need and the package manager will take responsibility for ensuring that-all the dependencies are installed.--Sometimes of course optional features and optional dependencies do make-sense. Cabal packages can have optional features and varying-dependencies. These conditional dependencies are still specified in a-declarative way however and remain compatible with automatic package-management. The need to remain compatible with automatic package-management means that Cabal's conditional dependencies system is a bit-less flexible than with the "./configure" approach.--### Portability ###--One of the purposes of Cabal is to make it easier to build packages on-different platforms (operating systems and CPU architectures), with-different compiler versions and indeed even with different Haskell-implementations. (Yes, there are Haskell implementations other than-GHC!)--Cabal provides abstractions of features present in different Haskell-implementations and wherever possible it is best to take advantage of-these to increase portability. Where necessary however it is possible to-use specific features of specific implementations.--For example a package author can list in the package's `.cabal` what-language extensions the code uses. This allows Cabal to figure out if-the language extension is supported by the Haskell implementation that-the user picks. Additionally, certain language extensions such as-Template Haskell require special handling from the build system and by-listing the extension it provides the build system with enough-information to do the right thing.--Another similar example is linking with foreign libraries. Rather than-specifying GHC flags directly, the package author can list the libraries-that are needed and the build system will take care of using the right-flags for the compiler. Additionally this makes it easier for tools to-discover what system C libraries a package needs, which is useful for-tracking dependencies on system libraries (e.g. when translating into-Linux distribution packages).--In fact both of these examples fall into the category of explicitly-specifying dependencies. Not all dependencies are other Cabal packages.-Foreign libraries are clearly another kind of dependency. It's also-possible to think of language extensions as dependencies: the package-depends on a Haskell implementation that supports all those extensions.--Where compiler-specific options are needed however, there is an "escape-hatch" available. The developer can specify implementation-specific-options and more generally there is a configuration mechanism to-customise many aspects of how a package is built depending on the-Haskell implementation, the operating system, computer architecture and-user-specified configuration flags.---# Developing packages #--The Cabal package is the unit of distribution. When installed, its-purpose is to make available:--  * One or more Haskell programs.--  * At most one library, exposing a number of Haskell modules.--However having both a library and executables in a package does not work-very well; if the executables depend on the library, they must-explicitly list all the modules they directly or indirectly import from-that library.  Fortunately, starting with Cabal 1.8.0.4, executables can-also declare the package that they are in as a dependency, and Cabal-will treat them as if they were in another package that depended on-the library.--Internally, the package may consist of much more than a bunch of Haskell-modules: it may also have C source code and header files, source code-meant for preprocessing, documentation, test cases, auxiliary tools etc.--A package is identified by a globally-unique _package name_, which-consists of one or more alphanumeric words separated by hyphens.  To-avoid ambiguity, each of these words should contain at least one letter.-Chaos will result if two distinct packages with the same name are-installed on the same system. A particular version of the package is-distinguished by a _version number_, consisting of a sequence of one or-more integers separated by dots.  These can be combined to form a single-text string called the _package ID_, using a hyphen to separate the name-from the version, e.g. "`HUnit-1.1`".--Note: Packages are not part of the Haskell language; they simply-populate the hierarchical space of module names. In GHC 6.6 and later a-program may contain multiple modules with the same name if they come-from separate packages; in all other current Haskell systems packages-may not overlap in the modules they provide, including hidden modules.---## Creating a package ##--Suppose you have a directory hierarchy containing the source files that-make up your package.  You will need to add two more files to the root-directory of the package:--_package_`.cabal`--:   a Unicode UTF-8 text file containing a package description.-    For details of the syntax of this file, see the [section on package-    descriptions](#package-descriptions).--`Setup.hs`--:   a single-module Haskell program to perform various setup tasks (with-    the interface described in the section on [building and installing-    packages](installing-packages.html). This module should-    import only modules that will be present in all Haskell-    implementations, including modules of the Cabal library. The-    content of this file is determined by the `build-type` setting in-    the `.cabal` file. In most cases it will be trivial, calling on-    the Cabal library to do most of the work.--Once you have these, you can create a source bundle of this directory-for distribution. Building of the package is discussed in the section on-[building and installing packages](installing-packages.html).--One of the purposes of Cabal is to make it easier to build a package-with different Haskell implementations. So it provides abstractions of-features present in different Haskell implementations and wherever-possible it is best to take advantage of these to increase portability.-Where necessary however it is possible to use specific features of-specific implementations. For example one of the pieces of information a-package author can put in the package's `.cabal` file is what language-extensions the code uses. This is far preferable to specifying flags for-a specific compiler as it allows Cabal to pick the right flags for the-Haskell implementation that the user picks. It also allows Cabal to-figure out if the language extension is even supported by the Haskell-implementation that the user picks. Where compiler-specific options are-needed however, there is an "escape hatch" available. The developer can-specify implementation-specific options and more generally there is a-configuration mechanism to customise many aspects of how a package is-built depending on the Haskell implementation, the Operating system,-computer architecture and user-specified configuration flags.--~~~~~~~~~~~~~~~~-name:     Foo-version:  1.0--library-  build-depends:   base-  exposed-modules: Foo-  extensions:      ForeignFunctionInterface-  ghc-options:     -Wall-  if os(windows)-    build-depends: Win32-~~~~~~~~~~~~~~~~--#### Example: A package containing a simple library ####--The HUnit package contains a file `HUnit.cabal` containing:--~~~~~~~~~~~~~~~~-name:           HUnit-version:        1.1.1-synopsis:       A unit testing framework for Haskell-homepage:       http://hunit.sourceforge.net/-category:       Testing-author:         Dean Herington-license:        BSD3-license-file:   LICENSE-cabal-version:  >= 1.10-build-type:     Simple--library-  build-depends:      base >= 2 && < 4-  exposed-modules:    Test.HUnit.Base, Test.HUnit.Lang,-                      Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit-  default-extensions: CPP-~~~~~~~~~~~~~~~~--and the following `Setup.hs`:--~~~~~~~~~~~~~~~~-import Distribution.Simple-main = defaultMain-~~~~~~~~~~~~~~~~--#### Example: A package containing executable programs ####--~~~~~~~~~~~~~~~~-name:           TestPackage-version:        0.0-synopsis:       Small package with two programs-author:         Angela Author-license:        BSD3-build-type:     Simple-cabal-version:  >= 1.2--executable program1-  build-depends:  HUnit-  main-is:        Main.hs-  hs-source-dirs: prog1--executable program2-  main-is:        Main.hs-  build-depends:  HUnit-  hs-source-dirs: prog2-  other-modules:  Utils-~~~~~~~~~~~~~~~~--with `Setup.hs` the same as above.--#### Example: A package containing a library and executable programs ####--~~~~~~~~~~~~~~~~-name:            TestPackage-version:         0.0-synopsis:        Package with library and two programs-license:         BSD3-author:          Angela Author-build-type:      Simple-cabal-version:   >= 1.2--library-  build-depends:   HUnit-  exposed-modules: A, B, C--executable program1-  main-is:         Main.hs-  hs-source-dirs:  prog1-  other-modules:   A, B--executable program2-  main-is:         Main.hs-  hs-source-dirs:  prog2-  other-modules:   A, C, Utils-~~~~~~~~~~~~~~~~--with `Setup.hs` the same as above. Note that any library modules-required (directly or indirectly) by an executable must be listed again.--The trivial setup script used in these examples uses the _simple build-infrastructure_ provided by the Cabal library (see-[Distribution.Simple][dist-simple]). The simplicity lies in its-interface rather that its implementation. It automatically handles-preprocessing with standard preprocessors, and builds packages for all-the Haskell implementations.--The simple build infrastructure can also handle packages where building-is governed by system-dependent parameters, if you specify a little more-(see the section on [system-dependent-parameters](#system-dependent-parameters)). A few packages require [more-elaborate solutions](#more-complex-packages).--## Package descriptions ##--The package description file must have a name ending in "`.cabal`".  It-must be a Unicode text file encoded using valid UTF-8. There must be-exactly one such file in the directory.  The first part of the name is-usually the package name, and some of the tools that operate on Cabal-packages require this.--In the package description file, lines whose first non-whitespace characters-are "`--`" are treated as comments and ignored.--This file should contain of a number global property descriptions and-several sections.--* The [global properties](#package-properties) describe the package as a-  whole, such as name, license, author, etc.--* Optionally, a number of _configuration flags_ can be declared.  These-  can be used to enable or disable certain features of a package. (see-  the section on [configurations](#configurations)).--* The (optional) library section specifies the [library-  properties](#library) and relevant [build-  information](#build-information).--* Following is an arbitrary number of executable sections-  which describe an executable program and relevant [build-  information](#build-information).--Each section consists of a number of property descriptions-in the form of field/value pairs, with a syntax roughly like mail-message headers.--* Case is not significant in field names, but is significant in field-  values.--* To continue a field value, indent the next line relative to the field-  name.--* Field names may be indented, but all field values in the same section-  must use the same indentation.--* Tabs are *not* allowed as indentation characters due to a missing-  standard interpretation of tab width.--* To get a blank line in a field value, use an indented "`.`"--The syntax of the value depends on the field.  Field types include:--_token_, _filename_, _directory_-:   Either a sequence of one or more non-space non-comma characters, or-    a quoted string in Haskell 98 lexical syntax. Unless otherwise-    stated, relative filenames and directories are interpreted from the-    package root directory.--_freeform_, _URL_, _address_-:   An arbitrary, uninterpreted string.--_identifier_-:   A letter followed by zero or more alphanumerics or underscores.--_compiler_-:   A compiler flavor (one of: `GHC`, `JHC`, `UHC` or `LHC`) followed by a-    version range.  For example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`.--### Modules and preprocessors ###--Haskell module names listed in the `exposed-modules` and `other-modules`-fields may correspond to Haskell source files, i.e. with names ending in-"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The-simple build infrastructure understands the extensions:--* `.gc` ([greencard][])-* `.chs` ([c2hs][])-* `.hsc` (`hsc2hs`)-* `.y` and `.ly` ([happy][])-* `.x` ([alex][])-* `.cpphs` ([cpphs][])--When building, Cabal will automatically run the appropriate preprocessor-and compile the Haskell module it produces.--Some fields take lists of values, which are optionally separated by commas,-except for the `build-depends` field, where the commas are mandatory.--Some fields are marked as required.  All others are optional, and unless-otherwise specified have empty default values.--### Package properties ###--These fields may occur in the first top-level properties section and-describe the package as a whole:--`name:` _package-name_ (required)-:   The unique name of the package, without the version number.--`version:` _numbers_ (required)-:   The package version number, usually consisting of a sequence of-    natural numbers separated by dots.--`cabal-version:`  _>= x.y_-:   The version of the Cabal specification that this package description uses.-    The Cabal specification does slowly evolve, introducing new features and-    occasionally changing the meaning of existing features. By specifying-    which version of the spec you are using it enables programs which process-    the package description to know what syntax to expect and what each part-    means.--    For historical reasons this is always expressed using _>=_ version range-    syntax. No other kinds of version range make sense, in particular upper-    bounds do not make sense. In future this field will specify just a version-    number, rather than a version range.--    The version number you specify will affect both compatibility and-    behaviour. Most tools (including the Cabal library and cabal program)-    understand a range of versions of the Cabal specification. Older tools-    will of course only work with older versions of the Cabal specification.-    Most of the time, tools that are too old will recognise this fact and-    produce a suitable error message.--    As for behaviour, new versions of the Cabal spec can change the meaning-    of existing syntax. This means if you want to take advantage of the new-    meaning or behaviour then you must specify the newer Cabal version.-    Tools are expected to use the meaning and behaviour appropriate to the-    version given in the package description.--    In particular, the syntax of package descriptions changed significantly-    with Cabal version 1.2 and the `cabal-version` field is now required.-    Files written in the old syntax are still recognized, so if you require-    compatibility with very old Cabal versions then you may write your package-    description file using the old syntax.  Please consult the user's guide of-    an older Cabal version for a description of that syntax.--`build-type:` _identifier_-:   The type of build used by this package. Build types are the-    constructors of the [BuildType][] type, defaulting to `Custom`.--    If the build type is anything other than `Custom`, then the-    `Setup.hs` file *must* be exactly the standardized content-    discussed below. This is because in these cases, `cabal` will-    ignore the `Setup.hs` file completely, whereas other methods of-    package management, such as `runhaskell Setup.hs [CMD]`, still-    rely on the `Setup.hs` file.--    For build type `Simple`, the contents of `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    For build type `Configure` (see the section on [system-dependent-    parameters](#system-dependent-parameters) below), the contents of-    `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMainWithHooks autoconfUserHooks-    ~~~~~~~~~~~~~~~~--    For build type `Make` (see the section on [more complex-    packages](installing-packages.html#more-complex-packages) below),-    the contents of `Setup.hs` must be:--    ~~~~~~~~~~~~~~~~-    import Distribution.Make-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    For build type `Custom`, the file `Setup.hs` can be customized,-    and will be used both by `cabal` and other tools.--    For most packages, the build type `Simple` is sufficient.--`license:` _identifier_ (default: `AllRightsReserved`)-:   The type of license under which this package is distributed.-    License names are the constants of the [License][dist-license] type.--`license-file:` _filename_ or `license-files:` _filename list_-:   The name of a file(s) containing the precise copyright license for-    this package. The license file(s) will be installed with the package.--    If you have multiple license files then use the `license-files`-    field instead of (or in addition to) the `license-file` field.--`copyright:` _freeform_-:   The content of a copyright notice, typically the name of the holder-    of the copyright on the package and the year(s) from which copyright-    is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs`--`author:` _freeform_-:   The original author of the package.--    Remember that `.cabal` files are Unicode, using the UTF-8 encoding.--`maintainer:` _address_-:   The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug-    reports, feature requests and patches.--`stability:` _freeform_-:   The stability level of the package, e.g. `alpha`, `experimental`, `provisional`,-    `stable`.--`homepage:` _URL_-:   The package homepage.--`bug-reports:` _URL_-:   The URL where users should direct bug reports. This would normally be either:--    * A `mailto:` URL, e.g. for a person or a mailing list.--    * An `http:` (or `https:`) URL for an online bug tracking system.--    For example Cabal itself uses a web-based bug tracking system--    ~~~~~~~~~~~~~~~~-    bug-reports: http://hackage.haskell.org/trac/hackage/-    ~~~~~~~~~~~~~~~~--`package-url:` _URL_-:   The location of a source bundle for the package. The distribution-    should be a Cabal package.--`synopsis:` _freeform_-:   A very short description of the package, for use in a table of-    packages.  This is your headline, so keep it short (one line) but as-    informative as possible. Save space by not including the package-    name or saying it's written in Haskell.--`description:` _freeform_-:   Description of the package.  This may be several paragraphs, and-    should be aimed at a Haskell programmer who has never heard of your-    package before.--    For library packages, this field is used as prologue text by [`setup-    haddock`](installing-packages.html#setup-haddock), and thus may-    contain the same markup as [haddock][] documentation comments.--`category:` _freeform_-:   A classification category for future use by the package catalogue [Hackage].  These-    categories have not yet been specified, but the upper levels of the-    module hierarchy make a good start.--`tested-with:` _compiler list_-:   A list of compilers and versions against which the package has been-    tested (or at least built).--`data-files:` _filename list_-:   A list of files to be installed for run-time use by the package.-    This is useful for packages that use a large amount of static data,-    such as tables of values  or code templates. Cabal provides a way to-    [find these files at-    run-time](#accessing-data-files-from-package-code).--    A limited form of `*` wildcards in file names, for example-    `data-files: images/*.png` matches all the `.png` files in the-    `images` directory.--    The limitation is that `*` wildcards are only allowed in place of-    the file name, not in the directory name or file extension.  In-    particular, wildcards do not include directories contents-    recursively. Furthermore, if a wildcard is used it must be used with-    an extension, so `data-files: data/*` is not allowed. When matching-    a wildcard plus extension, a file's full extension must match-    exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard-    that does not match any files is an error.--    The reason for providing only a very limited form of wildcard is to-    concisely express the common case of a large number of related files-    of the same file type without making it too easy to accidentally-    include unwanted files.--`data-dir:` _directory_-:   The directory where Cabal looks for data files to install, relative-    to the source directory. By default, Cabal will look in the source-    directory itself.--`extra-source-files:` _filename list_-:   A list of additional files to be included in source distributions-    built with [`setup sdist`](installing-packages.html#setup-sdist). As-    with `data-files` it can use a limited form of `*` wildcards in file-    names.--`extra-doc-files:` _filename list_-:   A list of additional files to be included in source distributions,-    and also copied to the html directory when Haddock documentation is-    generated. As with `data-files` it can use a limited form of `*`-    wildcards in file names.--`extra-tmp-files:` _filename list_-:   A list of additional files or directories to be removed by [`setup-    clean`](installing-packages.html#setup-clean). These would typically-    be additional files created by additional hooks, such as the scheme-    described in the section on [system-dependent-    parameters](#system-dependent-parameters).--### Library ###--The library section should contain the following fields:--`exposed-modules:` _identifier list_ (required if this package contains a library)-:   A list of modules added by this package.--`exposed:` _boolean_ (default: `True`)-:   Some Haskell compilers (notably GHC) support the notion of packages-    being "exposed" or "hidden" which means the modules they provide can-    be easily imported without always having to specify which package-    they come from. However this only works effectively if the modules-    provided by all exposed packages do not overlap (otherwise a module-    import would be ambiguous).--    Almost all new libraries use hierarchical module names that do not-    clash, so it is very uncommon to have to use this field. However it-    may be necessary to set `exposed: False` for some old libraries that-    use a flat module namespace or where it is known that the exposed-    modules would clash with other common modules.--`reexported-modules:` _exportlist _-:   Supported only in GHC 7.10 and later.  A list of modules to _reexport_ from-    this package.  The syntax of this field is `orig-pkg:Name as NewName` to-    reexport module `Name` from `orig-pkg` with the new name `NewName`.  We also-    support abbreviated versions of the syntax: if you omit `as NewName`,-    we'll reexport without renaming; if you omit `orig-pkg`, then we will-    automatically figure out which package to reexport from, if it's-    unambiguous.--    Reexported modules are useful for compatibility shims when a package has-    been split into multiple packages, and they have the useful property that-    if a package provides a module, and another package reexports it under-    the same name, these are not considered a conflict (as would be the case-    with a stub module.)  They can also be used to resolve name conflicts.--The library section may also contain build information fields (see the-section on [build information](#build-information)).--#### Opening an interpreter session ####--While developing a package, it is often useful to make its code available inside-an interpreter session. This can be done with the `repl` command:--~~~~~~~~~~~~~~~~-cabal repl-~~~~~~~~~~~~~~~~--The name comes from the acronym [REPL], which stands for-"read-eval-print-loop". By default `cabal repl` loads the first component in a-package. If the package contains several named components, the name can be given-as an argument to `repl`. The name can be also optionally prefixed with the-component's type for disambiguation purposes. Example:--~~~~~~~~~~~~~~~~-cabal repl foo-cabal repl exe:foo-cabal repl test:bar-cabal repl bench:baz-~~~~~~~~~~~~~~~~--#### Freezing dependency versions ####--If a package is built in several different environments, such as a development-environment, a staging environment and a production environment, it may be-necessary or desirable to ensure that the same dependency versions are-selected in each environment. This can be done with the `freeze` command:--~~~~~~~~~~~~~~~~-cabal freeze-~~~~~~~~~~~~~~~~--The command writes the selected version for all dependencies to the-`cabal.config` file.  All environments which share this file will use the-dependency versions specified in it.--### Executables ###--Executable sections (if present) describe executable programs contained-in the package and must have an argument after the section label, which-defines the name of the executable.  This is a freeform argument but may-not contain spaces.--The executable may be described using the following fields, as well as-build information fields (see the section on [build-information](#build-information)).--`main-is:` _filename_ (required)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the-    `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.--#### Running executables ####--You can have Cabal build and run your executables by using the `run` command:--~~~~~~~~~~~~~~~~-$ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS]-~~~~~~~~~~~~~~~~--This command will configure, build and run the executable `EXECUTABLE`. The-double dash separator is required to distinguish executable flags from `run`'s-own flags. If there is only one executable defined in the whole package, the-executable's name can be omitted. See the output of `cabal help run` for a list-of options you can pass to `cabal run`.---### Test suites ###--Test suite sections (if present) describe package test suites and must have an-argument after the section label, which defines the name of the test suite.-This is a freeform argument, but may not contain spaces.  It should be unique-among the names of the package's other test suites, the package's executables,-and the package itself.  Using test suite sections requires at least Cabal-version 1.9.2.--The test suite may be described using the following fields, as well as build-information fields (see the section on [build-information](#build-information)).--`type:` _interface_ (required)-:   The interface type and version of the test suite.  Cabal supports two test-    suite interfaces, called `exitcode-stdio-1.0` and `detailed-0.9`.  Each of-    these types may require or disallow other fields as described below.--Test suites using the `exitcode-stdio-1.0` interface are executables-that indicate test failure with a non-zero exit code when run; they may provide-human-readable log information through the standard output and error channels.-This interface is provided primarily for compatibility with existing test-suites; it is preferred that new test suites be written for the `detailed-0.9`-interface.  The `exitcode-stdio-1.0` type requires the `main-is` field.--`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-0.9`)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the-    `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.  This field is analogous to the-    `main-is` field of an executable section.--Test suites using the `detailed-0.9` interface are modules exporting the symbol-`tests :: IO [Test]`.  The `Test` type is exported by the module-`Distribution.TestSuite` provided by Cabal.  For more details, see the example below.--The `detailed-0.9` interface allows Cabal and other test agents to inspect a-test suite's results case by case, producing detailed human- and-machine-readable log files.  The `detailed-0.9` interface requires the-`test-module` field.--`test-module:` _identifier_ (required: `detailed-0.9`, disallowed: `exitcode-stdio-1.0`)-:   The module exporting the `tests` symbol.--#### Example: Package using `exitcode-stdio-1.0` interface ####--The example package description and executable source file below demonstrate-the use of the `exitcode-stdio-1.0` interface.  For brevity, the example package-does not include a library or any normal executables, but a real package would-be required to have at least one library or executable.--foo.cabal:--~~~~~~~~~~~~~~~~-Name:           foo-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Test-Suite test-foo-    type:       exitcode-stdio-1.0-    main-is:    test-foo.hs-    build-depends: base-~~~~~~~~~~~~~~~~--test-foo.hs:--~~~~~~~~~~~~~~~~-module Main where--import System.Exit (exitFailure)--main = do-    putStrLn "This test always fails!"-    exitFailure-~~~~~~~~~~~~~~~~--#### Example: Package using `detailed-0.9` interface ####--The example package description and test module source file below demonstrate-the use of the `detailed-0.9` interface.  For brevity, the example package does-note include a library or any normal executables, but a real package would be-required to have at least one library or executable.  The test module below-also develops a simple implementation of the interface set by-`Distribution.TestSuite`, but in actual usage the implementation would be-provided by the library that provides the testing facility.--bar.cabal:--~~~~~~~~~~~~~~~~-Name:           bar-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Test-Suite test-bar-    type:       detailed-0.9-    test-module: Bar-    build-depends: base, Cabal >= 1.9.2-~~~~~~~~~~~~~~~~--Bar.hs:--~~~~~~~~~~~~~~~~-module Bar ( tests ) where--import Distribution.TestSuite--tests :: IO [Test]-tests = return [ Test succeeds, Test fails ]-  where-    succeeds = TestInstance-        { run = return $ Finished Pass-        , name = "succeeds"-        , tags = []-        , options = []-        , setOption = \_ _ -> Right succeeds-        }-    fails = TestInstance-        { run = return $ Finished $ Fail "Always fails!"-        , name = "fails"-        , tags = []-        , options = []-        , setOption = \_ _ -> Right fails-        }-~~~~~~~~~~~~~~~~--#### Running test suites ####--You can have Cabal run your test suites using its built-in test-runner:--~~~~~~~~~~~~~~~~-$ cabal configure --enable-tests-$ cabal build-$ cabal test-~~~~~~~~~~~~~~~~--See the output of `cabal help test` for a list of options you can pass-to `cabal test`.--### Benchmarks ###--Benchmark sections (if present) describe benchmarks contained in the package and-must have an argument after the section label, which defines the name of the-benchmark.  This is a freeform argument, but may not contain spaces.  It should-be unique among the names of the package's other benchmarks, the package's test-suites, the package's executables, and the package itself.  Using benchmark-sections requires at least Cabal version 1.9.2.--The benchmark may be described using the following fields, as well as build-information fields (see the section on [build information](#build-information)).--`type:` _interface_ (required)-:   The interface type and version of the benchmark.  At the moment Cabal only-    support one benchmark interface, called `exitcode-stdio-1.0`.--Benchmarks using the `exitcode-stdio-1.0` interface are executables that-indicate failure to run the benchmark with a non-zero exit code when run; they-may provide human-readable information through the standard output and error-channels.--`main-is:` _filename_ (required: `exitcode-stdio-1.0`)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that-    it is the `.hs` filename that must be listed, even if that file is generated-    using a preprocessor. The source file must be relative to one of the-    directories listed in `hs-source-dirs`.  This field is analogous to the-    `main-is` field of an executable section.--#### Example: Package using `exitcode-stdio-1.0` interface ####--The example package description and executable source file below demonstrate-the use of the `exitcode-stdio-1.0` interface.  For brevity, the example package-does not include a library or any normal executables, but a real package would-be required to have at least one library or executable.--foo.cabal:--~~~~~~~~~~~~~~~~-Name:           foo-Version:        1.0-License:        BSD3-Cabal-Version:  >= 1.9.2-Build-Type:     Simple--Benchmark bench-foo-    type:       exitcode-stdio-1.0-    main-is:    bench-foo.hs-    build-depends: base, time-~~~~~~~~~~~~~~~~--bench-foo.hs:--~~~~~~~~~~~~~~~~-{-# LANGUAGE BangPatterns #-}-module Main where--import Data.Time.Clock--fib 0 = 1-fib 1 = 1-fib n = fib (n-1) + fib (n-2)--main = do-    start <- getCurrentTime-    let !r = fib 20-    end <- getCurrentTime-    putStrLn $ "fib 20 took " ++ show (diffUTCTime end start)-~~~~~~~~~~~~~~~~--#### Running benchmarks ####--You can have Cabal run your benchmark using its built-in benchmark runner:--~~~~~~~~~~~~~~~~-$ cabal configure --enable-benchmarks-$ cabal build-$ cabal bench-~~~~~~~~~~~~~~~~--See the output of `cabal help bench` for a list of options you can-pass to `cabal bench`.--### Build information ###--The following fields may be optionally present in a library or-executable section, and give information for the building of the-corresponding library or executable.  See also the sections on-[system-dependent parameters](#system-dependent-parameters) and-[configurations](#configurations) for a way to supply system-dependent-values for these fields.--`build-depends:` _package list_-:   A list of packages needed to build this one. Each package can be-    annotated with a version constraint.--    Version constraints use the operators `==, >=, >, <, <=` and a-    version number. Multiple constraints can be combined using `&&` or-    `||`. If no version constraint is specified, any version is assumed-    to be acceptable. For example:--    ~~~~~~~~~~~~~~~~-    library-      build-depends:-        base >= 2,-        foo >= 1.2 && < 1.3,-        bar-    ~~~~~~~~~~~~~~~~--    Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common-    because it is recommended practise for package versions to-    correspond to API versions. As of Cabal 1.6, there is a special-    syntax to support this use:--    ~~~~~~~~~~~~~~~~-    build-depends: foo ==1.2.*-    ~~~~~~~~~~~~~~~~--    It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`.--    With Cabal 1.20 and GHC 7.10, `build-depends` also supports module-    thinning and renaming, which allows you to selectively decide what-    modules become visible from a package dependency.  For example:--    ~~~~~~~~~~~~~~~~-    build-depends: containers (Data.Set, Data.IntMap as Map)-    ~~~~~~~~~~~~~~~~--    This results in only the modules `Data.Set` and `Map` being visible to-    the user from containers, hiding all other modules.  To add additional-    names for modules without hiding the others, you can use the `with`-    keyword:--    ~~~~~~~~~~~~~~~~-    build-depends: containers with (Data.IntMap as Map)-    ~~~~~~~~~~~~~~~~--    Note: Prior to Cabal 1.8, build-depends specified in each section-    were global to all sections. This was unintentional, but some packages-    were written to depend on it, so if you need your build-depends to-    be local to each section, you must specify at least-    `Cabal-Version: >= 1.8` in your `.cabal` file.--`other-modules:` _identifier list_-:   A list of modules used by the component but not exposed to users.-    For a library component, these would be hidden modules of the-    library. For an executable, these would be auxiliary modules to be-    linked with the file named in the `main-is` field.--    Note: Every module in the package *must* be listed in one of-    `other-modules`, `exposed-modules` or `main-is` fields.--`hs-source-dirs:` _directory list_ (default: "`.`")-:   Root directories for the module hierarchy.--    For backwards compatibility, the old variant `hs-source-dir` is also-    recognized.--`extensions:` _identifier list_-:   A list of Haskell extensions used by every module. Extension names-    are the constructors of the [Extension][extension] type. These-    determine corresponding compiler options. In particular, `CPP` specifies that-    Haskell source files are to be preprocessed with a C preprocessor.--    Extensions used only by one module may be specified by placing a-    `LANGUAGE` pragma in the source file affected, e.g.:--    ~~~~~~~~~~~~~~~~-    {-# LANGUAGE CPP, MultiParamTypeClasses #-}-    ~~~~~~~~~~~~~~~~--    Note:  GHC versions prior to 6.6 do not support the `LANGUAGE` pragma.--`build-tools:` _program list_-:   A list of programs, possibly annotated with versions, needed to-    build this package, e.g. `c2hs >= 0.15, cpphs`.If no version-    constraint is specified, any version is assumed to be acceptable.--`buildable:` _boolean_ (default: `True`)-:   Is the component buildable? Like some of the other fields below,-    this field is more useful with the slightly more elaborate form of-    the simple build infrastructure described in the section on-    [system-dependent parameters](#system-dependent-parameters).--`ghc-options:` _token list_-:   Additional options for GHC. You can often achieve the same effect-    using the `extensions` field, which is preferred.--    Options required only by one module may be specified by placing an-    `OPTIONS_GHC` pragma in the source file affected.--`ghc-prof-options:` _token list_-:   Additional options for GHC when the package is built with profiling-    enabled.--`ghc-shared-options:` _token list_-:   Additional options for GHC when the package is built as shared library.--`includes:` _filename list_-:   A list of header files to be included in any compilations via C.-    This field applies to both header files that are already installed-    on the system and to those coming with the package to be installed.-    These files typically contain function prototypes for foreign-    imports used by the package.--`install-includes:` _filename list_-:   A list of header files from this package to be installed into-    `$libdir/includes` when the package is installed. Files listed in-    `install-includes:` should be found in relative to the top of the-    source tree or relative to one of the directories listed in-    `include-dirs`.--    `install-includes` is typically used to name header files that-    contain prototypes for foreign imports used in Haskell code in this-    package, for which the C implementations are also provided with the-    package.  Note that to include them when compiling the package-    itself, they need to be listed in the `includes:` field as well.--`include-dirs:` _directory list_-:   A list of directories to search for header files, when preprocessing-    with `c2hs`, `hsc2hs`, `cpphs` or the C preprocessor, and-    also when compiling via C.--`c-sources:` _filename list_-:   A list of C source files to be compiled and linked with the Haskell files.--`js-sources:` _filename list_-:   A list of JavaScript source files to be linked with the Haskell files-    (only for JavaScript targets).--`extra-libraries:` _token list_-:   A list of extra libraries to link with.--`extra-ghci-libraries:` _token list_-:   A list of extra libraries to be used instead of 'extra-libraries' when-    the package is loaded with GHCi.--`extra-lib-dirs:` _directory list_-:   A list of directories to search for libraries.--`cc-options:` _token list_-:   Command-line arguments to be passed to the C compiler. Since the-    arguments are compiler-dependent, this field is more useful with the-    setup described in the section on [system-dependent-    parameters](#system-dependent-parameters).--`cpp-options:` _token list_-:   Command-line arguments for pre-processing Haskell code. Applies to-    haskell source and other pre-processed Haskell source like .hsc .chs.-    Does not apply to C code, that's what cc-options is for.--`ld-options:` _token list_-:   Command-line arguments to be passed to the linker. Since the-    arguments are compiler-dependent, this field is more useful with the-    setup described in the section on [system-dependent-    parameters](#system-dependent-parameters)>.--`pkgconfig-depends:` _package list_-:   A list of [pkg-config][] packages, needed to build this package.-    They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo-    >= 1.0`. If no version constraint is specified, any version is-    assumed to be acceptable. Cabal uses `pkg-config` to find if the-    packages are available on the system and to find the extra-    compilation and linker options needed to use the packages.--    If you need to bind to a C library that supports `pkg-config` (use-    `pkg-config --list-all` to find out if it is supported) then it is-    much preferable to use this field rather than hard code options into-    the other fields.--`frameworks:` _token list_-:   On Darwin/MacOS X, a list of frameworks to link to. See Apple's-    developer documentation for more details on frameworks.  This entry-    is ignored on all other platforms.--### Configurations ###--Library and executable sections may include conditional-blocks, which test for various system parameters and-configuration flags.  The flags mechanism is rather generic,-but most of the time a flag represents certain feature, that-can be switched on or off by the package user.-Here is an example package description file using-configurations:--#### Example: A package containing a library and executable programs ####--~~~~~~~~~~~~~~~~-Name: Test1-Version: 0.0.1-Cabal-Version: >= 1.2-License: BSD3-Author:  Jane Doe-Synopsis: Test package to test configurations-Category: Example--Flag Debug-  Description: Enable debug support-  Default:     False--Flag WebFrontend-  Description: Include API for web frontend.-  -- Cabal checks if the configuration is possible, first-  -- with this flag set to True and if not it tries with False--Library-  Build-Depends:   base-  Exposed-Modules: Testing.Test1-  Extensions:      CPP--  if flag(debug)-    GHC-Options: -DDEBUG-    if !os(windows)-      CC-Options: "-DDEBUG"-    else-      CC-Options: "-DNDEBUG"--  if flag(webfrontend)-    Build-Depends: cgi > 0.42-    Other-Modules: Testing.WebStuff--Executable test1-  Main-is: T1.hs-  Other-Modules: Testing.Test1-  Build-Depends: base--  if flag(debug)-    CC-Options: "-DDEBUG"-    GHC-Options: -DDEBUG-~~~~~~~~~~~~~~~~--#### Layout ####--Flags, conditionals, library and executable sections use layout to-indicate structure. This is very similar to the Haskell layout rule.-Entries in a section have to all be indented to the same level which-must be more than the section header. Tabs are not allowed to be used-for indentation.--As an alternative to using layout you can also use explicit braces `{}`.-In this case the indentation of entries in a section does not matter,-though different fields within a block must be on different lines. Here-is a bit of the above example again, using braces:--#### Example: Using explicit braces rather than indentation for layout ####--~~~~~~~~~~~~~~~~-Name: Test1-Version: 0.0.1-Cabal-Version: >= 1.2-License: BSD3-Author:  Jane Doe-Synopsis: Test package to test configurations-Category: Example--Flag Debug {-  Description: Enable debug support-  Default:     False-}--Library {-  Build-Depends:   base-  Exposed-Modules: Testing.Test1-  Extensions:      CPP-  if flag(debug) {-    GHC-Options: -DDEBUG-    if !os(windows) {-      CC-Options: "-DDEBUG"-    } else {-      CC-Options: "-DNDEBUG"-    }-  }-}-~~~~~~~~~~~~~~~~--#### Configuration Flags ####--A flag section takes the flag name as an argument and may contain the-following fields.--`description:` _freeform_-:   The description of this flag.--`default:` _boolean_ (default: `True`)-:   The default value of this flag.--    Note that this value may be [overridden in several-    ways](installing-packages.html#controlling-flag-assignments"). The-    rationale for having flags default to True is that users usually-    want new features as soon as they are available. Flags representing-    features that are not (yet) recommended for most users (such as-    experimental features or debugging support) should therefore-    explicitly override the default to False.--`manual:` _boolean_ (default: `False`)-:   By default, Cabal will first try to satisfy dependencies with the-    default flag value and then, if that is not possible, with the-    negated value. However, if the flag is manual, then the default-    value (which can be overridden by commandline flags) will be used.--#### Conditional Blocks ####--Conditional blocks may appear anywhere inside a library or executable-section.  They have to follow rather strict formatting rules.-Conditional blocks must always be of the shape--~~~~~~~~~~~~~~~~-  `if `_condition_-       _property-descriptions-or-conditionals*_-~~~~~~~~~~~~~~~~--or--~~~~~~~~~~~~~~~~-  `if `_condition_-       _property-descriptions-or-conditionals*_-  `else`-       _property-descriptions-or-conditionals*_-~~~~~~~~~~~~~~~~--Note that the `if` and the condition have to be all on the same line.--#### Conditions ####--Conditions can be formed using boolean tests and the boolean operators-`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"),-or `!` (negation / logical "not").  The unary `!` takes highest-precedence, `||` takes lowest.  Precedence levels may be overridden-through the use of parentheses. For example, `os(darwin) && !arch(i386)-|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) ||-os(freebsd)`.--The following tests are currently supported.--`os(`_name_`)`-:   Tests if the current operating system is _name_. The argument is-    tested against `System.Info.os` on the target system. There is-    unfortunately some disagreement between Haskell implementations-    about the standard values of `System.Info.os`. Cabal canonicalises-    it so that in particular `os(windows)` works on all implementations.-    If the canonicalised os names match, this test evaluates to true,-    otherwise false. The match is case-insensitive.--`arch(`_name_`)`-:   Tests if the current architecture is _name_.  The argument is-    matched against `System.Info.arch` on the target system. If the arch-    names match, this test evaluates to true, otherwise false. The match-    is case-insensitive.--`impl(`_compiler_`)`-:   Tests for the configured Haskell implementation. An optional version-    constraint may be specified (for example `impl(ghc >= 6.6.1)`). If-    the configured implementation is of the right type and matches the-    version constraint, then this evaluates to true, otherwise false.-    The match is case-insensitive.--`flag(`_name_`)`-:   Evaluates to the current assignment of the flag of the given name.-    Flag names are case insensitive. Testing for flags that have not-    been introduced with a flag section is an error.--`true`-:   Constant value true.--`false`-:   Constant value false.--#### Resolution of Conditions and Flags ####--If a package descriptions specifies configuration flags the package user can-[control these in several ways](installing-packages.html#controlling-flag-assignments).-If the user does not fix the value of a flag, Cabal will try to find a flag-assignment in the following way.--  * For each flag specified, it will assign its default value, evaluate-    all conditions with this flag assignment, and check if all-    dependencies can be satisfied.  If this check succeeded, the package-    will be configured with those flag assignments.--  * If dependencies were missing, the last flag (as by the order in-    which the flags were introduced in the package description) is tried-    with its alternative value and so on.  This continues until either-    an assignment is found where all dependencies can be satisfied, or-    all possible flag assignments have been tried.--To put it another way, Cabal does a complete backtracking search to find-a satisfiable package configuration. It is only the dependencies-specified in the `build-depends` field in conditional blocks that-determine if a particular flag assignment is satisfiable (`build-tools`-are not considered). The order of the declaration and the default value-of the flags determines the search order. Flags overridden on the-command line fix the assignment of that flag, so no backtracking will be-tried for that flag.--If no suitable flag assignment could be found, the configuration phase-will fail and a list of missing dependencies will be printed.  Note that-this resolution process is exponential in the worst case (i.e., in the-case where dependencies cannot be satisfied).  There are some-optimizations applied internally, but the overall complexity remains-unchanged.--### Meaning of field values when using conditionals ###--During the configuration phase, a flag assignment is chosen, all-conditionals are evaluated, and the package description is combined into-a flat package descriptions. If the same field both inside a conditional-and outside then they are combined using the following rules.---  * Boolean fields are combined using conjunction (logical "and").--  * List fields are combined by appending the inner items to the outer-    items, for example--    ~~~~~~~~~~~~~~~~-    Extensions: CPP-    if impl(ghc)-      Extensions: MultiParamTypeClasses-    ~~~~~~~~~~~~~~~~--    when compiled using GHC will be combined to--    ~~~~~~~~~~~~~~~~-    Extensions: CPP, MultiParamTypeClasses-    ~~~~~~~~~~~~~~~~--    Similarly, if two conditional sections appear at the same nesting-    level, properties specified in the latter will come after properties-    specified in the former.--  * All other fields must not be specified in ambiguous ways. For-    example--    ~~~~~~~~~~~~~~~~-    Main-is: Main.hs-    if flag(useothermain)-      Main-is: OtherMain.hs-    ~~~~~~~~~~~~~~~~--    will lead to an error.  Instead use--    ~~~~~~~~~~~~~~~~-    if flag(useothermain)-      Main-is: OtherMain.hs-    else-      Main-is: Main.hs-    ~~~~~~~~~~~~~~~~--### Source Repositories ###--It is often useful to be able to specify a source revision control-repository for a package. Cabal lets you specifying this information in-a relatively structured form which enables other tools to interpret and-make effective use of the information. For example the information-should be sufficient for an automatic tool to checkout the sources.--Cabal supports specifying different information for various common-source control systems. Obviously not all automated tools will support-all source control systems.--Cabal supports specifying repositories for different use cases. By-declaring which case we mean automated tools can be more useful. There-are currently two kinds defined:-- *  The `head` kind refers to the latest development branch of the-    package. This may be used for example to track activity of a project-    or as an indication to outside developers what sources to get for-    making new contributions.-- *  The `this` kind refers to the branch and tag of a repository that-    contains the sources for this version or release of a package. For most-    source control systems this involves specifying a tag, id or hash of-    some form and perhaps a branch. The purpose is to be able to-    reconstruct the sources corresponding to a particular package-    version. This might be used to indicate what sources to get if-    someone needs to fix a bug in an older branch that is no longer an-    active head branch.--You can specify one kind or the other or both. As an example here are-the repositories for the Cabal library. Note that the `this` kind of-repository specifies a tag.--~~~~~~~~~~~~~~~~-source-repository head-  type:     darcs-  location: http://darcs.haskell.org/cabal/--source-repository this-  type:     darcs-  location: http://darcs.haskell.org/cabal-branches/cabal-1.6/-  tag:      1.6.1-~~~~~~~~~~~~~~~~--The exact fields are as follows:--`type:` _token_-:   The name of the source control system used for this repository. The-    currently recognised types are:--    * `darcs`-    * `git`-    * `svn`-    * `cvs`-    * `mercurial` (or alias `hg`)-    * `bazaar` (or alias `bzr`)-    * `arch`-    * `monotone`--    This field is required.--`location:` _URL_-:   The location of the repository. The exact form of this field depends-    on the repository type. For example:--    * for darcs: `http://code.haskell.org/foo/`-    * for git: `git://github.com/foo/bar.git`-    * for CVS: `anoncvs@cvs.foo.org:/cvs`--    This field is required.--`module:` _token_-:   CVS requires a named module, as each CVS server can host multiple-    named repositories.--    This field is required for the CVS repository type and should not-    be used otherwise.--`branch:` _token_-:   Many source control systems support the notion of a branch, as a-    distinct concept from having repositories in separate locations. For-    example CVS, SVN and git use branches while for darcs uses different-    locations for different branches. If you need to specify a branch to-    identify a your repository then specify it in this field.--    This field is optional.--`tag:` _token_-:   A tag identifies a particular state of a source repository. The tag-    can be used with a `this` repository kind to identify the state of-    a repository corresponding to a particular package version or-    release. The exact form of the tag depends on the repository type.--    This field is required for the `this` repository kind.--`subdir:` _directory_-:   Some projects put the sources for multiple packages under a single-    source repository. This field lets you specify the relative path-    from the root of the repository to the top directory for the-    package, i.e. the directory containing the package's `.cabal` file.--    This field is optional. It default to empty which corresponds to the-    root directory of the repository.--### Downloading a package's source ###--The `cabal get` command allows to access a package's source code - either by-unpacking a tarball downloaded from Hackage (the default) or by checking out a-working copy from the package's source repository.--~~~~~~~~~~~~~~~~-$ cabal get [FLAGS] PACKAGES-~~~~~~~~~~~~~~~~--The `get` command supports the following options:--`-d --destdir` _PATH_-:   Where to place the package source, defaults to (a subdirectory of) the-    current directory.--`-s --source-repository` _[head|this|...]_-:   Fork the package's source repository using the appropriate version control-    system. The optional argument allows to choose a specific repository kind.---## Accessing data files from package code ##--The placement on the target system of files listed in the `data-files`-field varies between systems, and in some cases one can even move-packages around after installation (see [prefix-independence](installing-packages.html#prefix-independence)). To enable-packages to find these files in a portable way, Cabal generates a module-called `Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by-underscores) during building, so that it may be imported by modules of-the package.  This module defines a function--~~~~~~~~~~~~~~~-getDataFileName :: FilePath -> IO FilePath-~~~~~~~~~~~~~~~--If the argument is a filename listed in the `data-files` field, the-result is the name of the corresponding file on the system on which the-program is running.--Note: If you decide to import the `Paths_`_pkgname_ module then it-*must* be listed in the `other-modules` field just like any other module-in your package.--The `Paths_`_pkgname_ module is not platform independent so it does not-get included in the source tarballs generated by `sdist`.--### Accessing the package version ###--The aforementioned auto generated `Paths_`_pkgname_ module also-exports the constant `version ::` [Version][data-version] which is-defined as the version of your package as specified in the `version`-field.--## System-dependent parameters ##--For some packages, especially those interfacing with C libraries,-implementation details and the build procedure depend on the build-environment. The `build-type` `Configure` can be used to handle many-such situations. In this case, `Setup.hs` should be:--~~~~~~~~~~~~~~~~-import Distribution.Simple-main = defaultMainWithHooks autoconfUserHooks-~~~~~~~~~~~~~~~~--Most packages, however, would probably do better using the `Simple`-build type and [configurations](#configurations).--The `build-type` `Configure` differs from `Simple` in two ways:--* The package root directory must contain a shell script called-  `configure`. The configure step will run the script. This `configure`-  script may be produced by [autoconf][] or may be hand-written. The-  `configure` script typically discovers information about the system-  and records it for later steps, e.g. by generating system-dependent-  header files for inclusion in C source files and preprocessed Haskell-  source files. (Clearly this won't work for Windows without MSYS or-  Cygwin: other ideas are needed.)--* If the package root directory contains a file called-  _package_`.buildinfo` after the configuration step, subsequent steps-  will read it to obtain additional settings for [build-  information](#build-information) fields,to be merged with the ones-  given in the `.cabal` file. In particular, this file may be generated-  by the `configure` script mentioned above, allowing these settings to-  vary depending on the build environment.--  The build information file should have the following structure:--  > _buildinfo_-  >-  > `executable:` _name_-  > _buildinfo_-  >-  > `executable:` _name_-  > _buildinfo_-  > ...--  where each _buildinfo_ consists of settings of fields listed in the-  section on [build information](#build-information). The first one (if-  present) relates to the library, while each of the others relate to-  the named executable.  (The names must match the package description,-  but you don't have to have entries for all of them.)--Neither of these files is required.  If they are absent, this setup-script is equivalent to `defaultMain`.--#### Example: Using autoconf ####--This example is for people familiar with the [autoconf][] tools.--In the X11 package, the file `configure.ac` contains:--~~~~~~~~~~~~~~~~-AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11])--# Safety check: Ensure that we are in the correct source directory.-AC_CONFIG_SRCDIR([X11.cabal])--# Header file to place defines in-AC_CONFIG_HEADERS([include/HsX11Config.h])--# Check for X11 include paths and libraries-AC_PATH_XTRA-AC_TRY_CPP([#include <X11/Xlib.h>],,[no_x=yes])--# Build the package if we found X11 stuff-if test "$no_x" = yes-then BUILD_PACKAGE_BOOL=False-else BUILD_PACKAGE_BOOL=True-fi-AC_SUBST([BUILD_PACKAGE_BOOL])--AC_CONFIG_FILES([X11.buildinfo])-AC_OUTPUT-~~~~~~~~~~~~~~~~--Then the setup script will run the `configure` script, which checks for-the presence of the X11 libraries and substitutes for variables in the-file `X11.buildinfo.in`:--~~~~~~~~~~~~~~~~-buildable: @BUILD_PACKAGE_BOOL@-cc-options: @X_CFLAGS@-ld-options: @X_LIBS@-~~~~~~~~~~~~~~~~--This generates a file `X11.buildinfo` supplying the parameters needed by-later stages:--~~~~~~~~~~~~~~~~-buildable: True-cc-options:  -I/usr/X11R6/include-ld-options:  -L/usr/X11R6/lib-~~~~~~~~~~~~~~~~--The `configure` script also generates a header file `include/HsX11Config.h`-containing C preprocessor defines recording the results of various tests.  This-file may be included by C source files and preprocessed Haskell source files in-the package.--Note: Packages using these features will also need to list additional files such-as `configure`, templates for `.buildinfo` files, files named only in-`.buildinfo` files, header files and so on in the `extra-source-files` field to-ensure that they are included in source distributions.  They should also list-files and directories generated by `configure` in the `extra-tmp-files` field to-ensure that they are removed by `setup clean`.--Quite often the files generated by `configure` need to be listed somewhere in-the package description (for example, in the `install-includes` field). However,-we usually don't want generated files to be included in the source tarball. The-solution is again provided by the `.buildinfo` file. In the above example, the-following line should be added to `X11.buildinfo`:--~~~~~~~~~~~~~~~~-install-includes: HsX11Config.h-~~~~~~~~~~~~~~~~--In this way, the generated `HsX11Config.h` file won't be included in the source-tarball in addition to `HsX11Config.h.in`, but it will be copied to the right-location during the install process. Packages that use custom `Setup.hs` scripts-can update the necessary fields programmatically instead of using the-`.buildinfo` file.---## Conditional compilation ##--Sometimes you want to write code that works with more than one version-of a dependency.  You can specify a range of versions for the dependency-in the `build-depends`, but how do you then write the code that can use-different versions of the API?--Haskell lets you preprocess your code using the C preprocessor (either-the real C preprocessor, or `cpphs`).  To enable this, add `extensions:-CPP` to your package description.  When using CPP, Cabal provides some-pre-defined macros to let you test the version of dependent packages;-for example, suppose your package works with either version 3 or version-4 of the `base` package, you could select the available version in your-Haskell modules like this:--~~~~~~~~~~~~~~~~-#if MIN_VERSION_base(4,0,0)-... code that works with base-4 ...-#else-... code that works with base-3 ...-#endif-~~~~~~~~~~~~~~~~--In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)`-for each package depended on via `build-depends`. This macro is true if-the actual version of the package in use is greater than or equal to-`A.B.C` (using the conventional ordering on version numbers, which is-lexicographic on the sequence, but numeric on each component, so for-example 1.2.0 is greater than 1.0.3).--Since version 1.20, there is also the `MIN_TOOL_VERSION_`_`tool`_ family of-macros for conditioning on the version of build tools used to build the program-(e.g. `hsc2hs`).--Cabal places the definitions of these macros into an-automatically-generated header file, which is included when-preprocessing Haskell source code by passing options to the C-preprocessor.--Cabal also allows to detect when the source code is being used for generating-documentation. The `__HADDOCK_VERSION__` macro is defined only when compiling-via [haddock][] instead of a normal Haskell compiler. The value of the-`__HADDOCK_VERSION__` macro is defined as `A*1000 + B*10 + C`, where `A.B.C` is-the Haddock version. This can be useful for working around bugs in Haddock or-generating prettier documentation in some special cases.--## More complex packages ##--For packages that don't fit the simple schemes described above, you have-a few options:--  * By using the `build-type` `Custom`, you can supply your own-    `Setup.hs` file, and customize the simple build infrastructure-    using _hooks_.  These allow you to perform additional actions-    before and after each command is run, and also to specify-    additional preprocessors. A typical `Setup.hs` may look like this:--    ~~~~~~~~~~~~~~~~-    import Distribution.Simple-    main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock }--    posthaddock args flags desc info = ....-    ~~~~~~~~~~~~~~~~--    See `UserHooks` in [Distribution.Simple][dist-simple] for the-    details, but note that this interface is experimental, and likely-    to change in future releases.--  * You could delegate all the work to `make`, though this is unlikely-    to be very portable. Cabal supports this with the `build-type`-    `Make` and a trivial setup library [Distribution.Make][dist-make],-    which simply parses the command line arguments and invokes `make`.-    Here `Setup.hs` should look like this:--    ~~~~~~~~~~~~~~~~-    import Distribution.Make-    main = defaultMain-    ~~~~~~~~~~~~~~~~--    The root directory of the package should contain a `configure`-    script, and, after that has run, a `Makefile` with a default target-    that builds the package, plus targets `install`, `register`,-    `unregister`, `clean`, `dist` and `docs`. Some options to commands-    are passed through as follows:--      * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`,-        `--libexecdir` and `--sysconfdir` options to the `configure` command are-        passed on to the `configure` script. In addition the value of the-        `--with-compiler` option is passed in a `--with-hc` option and all-        options specified with `--configure-option=` are passed on.--      * The `--destdir` option to the `copy` command becomes a setting-        of a `destdir` variable on the invocation of `make copy`. The-        supplied `Makefile` should provide a `copy` target, which will-        probably look like this:--        ~~~~~~~~~~~~~~~~-        copy :-                $(MAKE) install prefix=$(destdir)/$(prefix) \-                                bindir=$(destdir)/$(bindir) \-                                libdir=$(destdir)/$(libdir) \-                                datadir=$(destdir)/$(datadir) \-                                libexecdir=$(destdir)/$(libexecdir) \-                                sysconfdir=$(destdir)/$(sysconfdir) \-        ~~~~~~~~~~~~~~~~--  * Finally, with the `build-type` `Custom`, you can also write your-    own setup script from scratch. It must conform to the interface-    described in the section on [building and installing-    packages](installing-packages.html), and you may use the Cabal-    library for all or part of the work.  One option is to copy the-    source of `Distribution.Simple`, and alter it for your needs. Good-    luck.----[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/-[REPL]:       http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop
− doc/index.markdown 
@@ -1,200 +0,0 @@-% Cabal User Guide--Cabal is the standard package system for [Haskell] software. It helps-people to configure, build and install Haskell software and to-distribute it easily to other users and developers.--There is a command line tool called `cabal` for working with Cabal-packages. It helps with installing existing packages and also helps-people developing their own packages. It can be used to work with local-packages or to install packages from online package archives, including-automatically installing dependencies. By default it is configured to-use [Hackage] which is Haskell's central package archive that contains-thousands of libraries and applications in the Cabal package format.--# Contents #--  * [Introduction](#introduction)-      - [What's in a package](#whats-in-a-package)-      - [A tool for working with packages](#a-tool-for-working-with-packages)-  * [Building, installing and managing packages](installing-packages.html)-  * [Creating packages](developing-packages.html)-  * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies)-  * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces)--# Introduction #--Cabal is a package system for Haskell software. The point of a package-system is to enable software developers and users to easily distribute,-use and reuse software. A package system makes it easier for developers-to get their software into the hands of users. Equally importantly, it-makes it easier for software developers to be able to reuse software-components written by other developers.--Packaging systems deal with packages and with Cabal we call them _Cabal-packages_. The Cabal package is the unit of distribution. Every Cabal-package has a name and a version number which are used to identify the-package, e.g. `filepath-1.0`.--Cabal packages can depend on other Cabal packages. There are tools-to enable automated package management. This means it is possible for-developers and users to install a package plus all of the other Cabal-packages that it depends on. It also means that it is practical to make-very modular systems using lots of packages that reuse code written by-many developers.--Cabal packages are source based and are typically (but not necessarily)-portable to many platforms and Haskell implementations. The Cabal-package format is designed to make it possible to translate into other-formats, including binary packages for various systems.--When distributed, Cabal packages use the standard compressed tarball-format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`.--Note that packages are not part of the Haskell language, rather they-are a feature provided by the combination of Cabal and GHC (and several-other Haskell implementations).---## A tool for working with packages ##--There is a command line tool, called "`cabal`", that users and developers-can use to build and install Cabal packages. It can be used for both-local packages and for packages available remotely over the network. It-can automatically install Cabal packages plus any other Cabal packages-they depend on.--Developers can use the tool with packages in local directories, e.g.--~~~~~~~~~~~~~~~~-cd foo/-cabal install-~~~~~~~~~~~~~~~~--While working on a package in a local directory, developers can run the-individual steps to configure and build, and also generate documentation-and run test suites and benchmarks.--It is also possible to install several local packages at once, e.g.--~~~~~~~~~~~~~~~~-cabal install foo/ bar/-~~~~~~~~~~~~~~~~--Developers and users can use the tool to install packages from remote-Cabal package archives. By default, the `cabal` tool is configured to-use the central Haskell package archive called [Hackage] but it-is possible to use it with any other suitable archive.--~~~~~~~~~~~~~~~~-cabal install xmonad-~~~~~~~~~~~~~~~~--This will install the `xmonad` package plus all of its dependencies.--In addition to packages that have been published in an archive,-developers can install packages from local or remote tarball files,-for example--~~~~~~~~~~~~~~~~-cabal install foo-1.0.tar.gz-cabal install http://example.com/foo-1.0.tar.gz-~~~~~~~~~~~~~~~~--Cabal provides a number of ways for a user to customise how and where a-package is installed. They can decide where a package will be installed,-which Haskell implementation to use and whether to build optimised code-or build with the ability to profile code. It is not expected that users-will have to modify any of the information in the `.cabal` file.--For full details, see the section on [building and installing-packages](installing-packages.html).--Note that `cabal` is not the only tool for working with Cabal packages.-Due to the standardised format and a library for reading `.cabal` files,-there are several other special-purpose tools.--## What's in a package ##--A Cabal package consists of:--  * Haskell software, including libraries, executables and tests-  * metadata about the package in a standard human and machine-    readable format (the "`.cabal`" file)-  * a standard interface to build the package (the "`Setup.hs`" file)--The `.cabal` file contains information about the package, supplied by-the package author. In particular it lists the other Cabal packages-that the package depends on.--For full details on what goes in the `.cabal` and `Setup.hs` files, and-for all the other features provided by the build system, see the section-on [developing packages](developing-packages.html).---## Cabal featureset ##--Cabal and its associated tools and websites covers:-- * a software build system- * software configuration- * packaging for distribution- * automated package management-    * natively using the `cabal` command line tool; or-    * by translation into native package formats such as RPM or deb- * web and local Cabal package archives-    * central Hackage website with 1000's of Cabal packages--Some parts of the system can be used without others. In particular the-built-in build system for simple packages is optional: it is possible-to use custom build systems.--## Similar systems ##--The Cabal system is roughly comparable with the system of Python Eggs,-Ruby Gems or Perl distributions. Each system has a notion of-distributable packages, and has tools to manage the process of-distributing and installing packages.--Hackage is an online archive of Cabal packages. It is roughly comparable-to CPAN but with rather fewer packages (around 5,000 vs 28,000).--Cabal is often compared with autoconf and automake and there is some-overlap in functionality. The most obvious similarity is that the-command line interface for actually configuring and building packages-follows the same steps and has many of the same configuration-parameters.--~~~~~~~~~~-./configure --prefix=...-make-make install-~~~~~~~~~~--compared to--~~~~~~~~~~-cabal configure --prefix=...-cabal build-cabal install-~~~~~~~~~~--Cabal's build system for simple packages is considerably less flexible-than make/automake, but has builtin knowledge of how to build Haskell-code and requires very little manual configuration. Cabal's simple build-system is also portable to Windows, without needing a Unix-like-environment such as cygwin/mingwin.--Compared to autoconf, Cabal takes a somewhat different approach to-package configuration. Cabal's approach is designed for automated-package management. Instead of having a configure script that tests for-whether dependencies are available, Cabal packages specify their-dependencies. There is some scope for optional and conditional-dependencies. By having package authors specify dependencies it makes it-possible for tools to install a package and all of its dependencies-automatically. It also makes it possible to translate (in a-mostly-automatically way) into another package format like RPM or deb-which also have automatic dependency resolution.--[Haskell]:  http://www.haskell.org/-[Hackage]:  http://hackage.haskell.org/
− doc/installing-packages.markdown 
@@ -1,1067 +0,0 @@-% Cabal User Guide--# Building and installing packages #--After you've unpacked a Cabal package, you can build it by moving into-the root directory of the package and running the `cabal` tool there:--> `cabal [command] [option...]`--The _command_ argument selects a particular step in the build/install process.--You can also get a summary of the command syntax with--> `cabal help`--Alternatively, you can also use the `Setup.hs` or `Setup.lhs` script:--> `runhaskell Setup.hs [command] [option...]`--For the summary of the command syntax, run:--> `cabal help`--or--> `runhaskell Setup.hs --help`--## Building and installing a system package ##--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --ghc-runhaskell Setup.hs build-runhaskell Setup.hs install-~~~~~~~~~~~~~~~~--The first line readies the system to build the tool using GHC; for-example, it checks that GHC exists on the system.  The second line-performs the actual building, while the last both copies the build-results to some permanent place and registers the package with GHC.--## Building and installing a user package ##--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --user-runhaskell Setup.hs build-runhaskell Setup.hs install-~~~~~~~~~~~~~~~~--The package is installed under the user's home directory and is-registered in the user's package database (`--user`).--## Installing packages from Hackage ##--The `cabal` tool also can download, configure, build and install a [Hackage]-package and all of its dependencies in a single step. To do this, run:--~~~~~~~~~~~~~~~~-cabal install [PACKAGE...]-~~~~~~~~~~~~~~~~--To browse the list of available packages, visit the [Hackage] web site.--## Developing with sandboxes ##--By default, any dependencies of the package are installed into the global or-user package databases (e.g. using `cabal install --only-dependencies`). If-you're building several different packages that have incompatible dependencies,-this can cause the build to fail. One way to avoid this problem is to build each-package in an isolated environment ("sandbox"), with a sandbox-local package-database. Because sandboxes are per-project, inconsistent dependencies can be-simply disallowed.--For more on sandboxes, see also-[this article](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html).--### Sandboxes: basic usage ###--To initialise a fresh sandbox in the current directory, run `cabal sandbox-init`. All subsequent commands (such as `build` and `install`) from this point-will use the sandbox.--~~~~~~~~~~~~~~~-$ cd /path/to/my/haskell/library-$ cabal sandbox init                   # Initialise the sandbox-$ cabal install --only-dependencies    # Install dependencies into the sandbox-$ cabal build                          # Build your package inside the sandbox-~~~~~~~~~~~~~~~--It can be useful to make a source package available for installation in the-sandbox - for example, if your package depends on a patched or an unreleased-version of a library. This can be done with the `cabal sandbox add-source`-command - think of it as "local [Hackage]". If an add-source dependency is later-modified, it is reinstalled automatically.--~~~~~~~~~~~~~~~-$ cabal sandbox add-source /my/patched/library # Add a new add-source dependency-$ cabal install --dependencies-only            # Install it into the sandbox-$ cabal build                                  # Build the local package-$ $EDITOR /my/patched/library/Source.hs        # Modify the add-source dependency-$ cabal build                                  # Modified dependency is automatically reinstalled-~~~~~~~~~~~~~~~--Normally, the sandbox settings (such as optimisation level) are inherited from-the main Cabal config file (`$HOME/cabal/config`). Sometimes, though, you need-to change some settings specifically for a single sandbox. You can do this by-creating a `cabal.config` file in the same directory with your-`cabal.sandbox.config` (which was created by `sandbox init`). This file has the-same syntax as the main Cabal config file.--~~~~~~~~~~~~~~~-$ cat cabal.config-documentation: True-constraints: foo == 1.0, bar >= 2.0, baz-$ cabal build                                  # Uses settings from the cabal.config file-~~~~~~~~~~~~~~~--When you have decided that you no longer want to build your package inside a-sandbox, just delete it:--~~~~~~~~~~~~~~~-$ cabal sandbox delete                       # Built-in command-$ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method-~~~~~~~~~~~~~~~--### Sandboxes: advanced usage ###--The default behaviour of the `add-source` command is to track modifications done-to the added dependency and reinstall the sandbox copy of the package when-needed. Sometimes this is not desirable: in these cases you can use `add-source---snapshot`, which disables the change tracking. In addition to `add-source`,-there are also `list-sources` and `delete-source` commands.--Sometimes one wants to share a single sandbox between multiple packages. This-can be easily done with the `--sandbox` option:--~~~~~~~~~~~~~~~-$ mkdir -p /path/to/shared-sandbox-$ cd /path/to/shared-sandbox-$ cabal sandbox init --sandbox .-$ cd /path/to/package-a-$ cabal sandbox init --sandbox /path/to/shared-sandbox-$ cd /path/to/package-b-$ cabal sandbox init --sandbox /path/to/shared-sandbox-~~~~~~~~~~~~~~~--Note that `cabal sandbox init --sandbox .` puts all sandbox files into the-current directory. By default, `cabal sandbox init` initialises a new sandbox in-a newly-created subdirectory of the current working directory-(`./.cabal-sandbox`).--Using multiple different compiler versions simultaneously is also supported, via-the `-w` option:--~~~~~~~~~~~~~~~-$ cabal sandbox init-$ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers-$ cabal install --only-dependencies -w /path/to/ghc-2-$ cabal configure -w /path/to/ghc-1                   # Build with the first compiler-$ cabal build-$ cabal configure -w /path/to/ghc-2                   # Build with the second compiler-$ cabal build-~~~~~~~~~~~~~~~--It can be occasionally useful to run the compiler-specific package manager tool-(e.g. `ghc-pkg`) tool on the sandbox package DB directly (for example, you may-need to unregister some packages). The `cabal sandbox hc-pkg` command is a-convenient wrapper that runs the compiler-specific package manager tool with the-arguments:--~~~~~~~~~~~~~~~-$ cabal -v sandbox hc-pkg list-Using a sandbox located at /path/to/.cabal-sandbox-'ghc-pkg' '--global' '--no-user-package-conf'-    '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d'-    'list'-[...]-~~~~~~~~~~~~~~~--The `--require-sandbox` option makes all sandbox-aware commands-(`install`/`build`/etc.) exit with error if there is no sandbox present. This-makes it harder to accidentally modify the user package database. The option can-be also turned on via the per-user configuration file (`~/.cabal/config`) or the-per-project one (`$PROJECT_DIR/cabal.config`). The error can be squelched with-`--no-require-sandbox`.--The option `--sandbox-config-file` allows to specify the location of the-`cabal.sandbox.config` file (by default, `cabal` searches for it in the current-directory). This provides the same functionality as shared sandboxes, but-sometimes can be more convenient. Example:--~~~~~~~~~~~~~~~-$ mkdir my/sandbox-$ cd my/sandbox-$ cabal sandbox init-$ cd /path/to/my/project-$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install-# Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox-$ cd ~-$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install-# Still uses the same sandbox-~~~~~~~~~~~~~~~--The sandbox config file can be also specified via the `CABAL_SANDBOX_CONFIG`-environment variable.--Finally, the flag `--ignore-sandbox` lets you temporarily ignore an existing-sandbox:--~~~~~~~~~~~~~~~-$ mkdir my/sandbox-$ cd my/sandbox-$ cabal sandbox init-$ cabal --ignore-sandbox install text-# Installs 'text' in the user package database ('~/.cabal').-~~~~~~~~~~~~~~~--## Creating a binary package ##--When creating binary packages (e.g. for Red Hat or Debian) one needs to-create a tarball that can be sent to another system for unpacking in the-root directory:--~~~~~~~~~~~~~~~~-runhaskell Setup.hs configure --prefix=/usr-runhaskell Setup.hs build-runhaskell Setup.hs copy --destdir=/tmp/mypkg-tar -czf mypkg.tar.gz /tmp/mypkg/-~~~~~~~~~~~~~~~~--If the package contains a library, you need two additional steps:--~~~~~~~~~~~~~~~~-runhaskell Setup.hs register --gen-script-runhaskell Setup.hs unregister --gen-script-~~~~~~~~~~~~~~~~--This creates shell scripts `register.sh` and `unregister.sh`, which must-also be sent to the target system.  After unpacking there, the package-must be registered by running the `register.sh` script. The-`unregister.sh` script would be used in the uninstall procedure of the-package. Similar steps may be used for creating binary packages for-Windows.---The following options are understood by all commands:--`--help`, `-h` or `-?`-:   List the available options for the command.--`--verbose=`_n_ or `-v`_n_-:   Set the verbosity level (0-3). The normal level is 1; a missing _n_-    defaults to 2.--The various commands and the additional options they support are-described below. In the simple build infrastructure, any other options-will be reported as errors.--## setup configure ##--Prepare to build the package.  Typically, this step checks that the-target platform is capable of building the package, and discovers-platform-specific features that are needed during the build.--The user may also adjust the behaviour of later stages using the options-listed in the following subsections.  In the simple build-infrastructure, the values supplied via these options are recorded in a-private file read by later stages.--If a user-supplied `configure` script is run (see the section on-[system-dependent-parameters](developing-packages.html#system-dependent-parameters) or on-[complex packages](developing-packages.html#more-complex-packages)), it-is passed the `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`,-`--datadir`, `--libexecdir` and `--sysconfdir` options. In addition the-value of the `--with-compiler` option is passed in a `--with-hc` option-and all options specified with `--configure-option=` are passed on.--### Programs used for building ###--The following options govern the programs used to process the source-files of a package:--`--ghc` or `-g`, `--jhc`, `--lhc`, `--uhc`-:   Specify which Haskell implementation to use to build the package.-    At most one of these flags may be given. If none is given, the-    implementation under which the setup script was compiled or-    interpreted is used.--`--with-compiler=`_path_ or `-w`_path_-:   Specify the path to a particular compiler. If given, this must match-    the implementation selected above. The default is to search for the-    usual name of the selected implementation.--    This flag also sets the default value of the `--with-hc-pkg` option-    to the package tool for this compiler. Check the output of `setup-    configure -v` to ensure that it finds the right package tool (or use-    `--with-hc-pkg` explicitly).---`--with-hc-pkg=`_path_-:   Specify the path to the package tool, e.g. `ghc-pkg`. The package-    tool must be compatible with the compiler specified by-    `--with-compiler`. If this option is omitted, the default value is-    determined from the compiler selected.--`--with-`_`prog`_`=`_path_-:   Specify the path to the program _prog_. Any program known to Cabal-    can be used in place of _prog_. It can either be a fully path or the-    name of a program that can be found on the program search path. For-    example: `--with-ghc=ghc-6.6.1` or-    `--with-cpphs=/usr/local/bin/cpphs`.-    The full list of accepted programs is not enumerated in this user guide.-    Rather, run `cabal install --help` to view the list.--`--`_`prog`_`-options=`_options_-:   Specify additional options to the program _prog_. Any program known-    to Cabal can be used in place of _prog_. For example:-    `--alex-options="--template=mytemplatedir/"`. The _options_ is split-    into program options based on spaces. Any options containing embedded-    spaced need to be quoted, for example-    `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative-    that takes only one option at a time but avoids the need to quote,-    use `--`_`prog`_`-option` instead.--`--`_`prog`_`-option=`_option_-:   Specify a single additional option to the program _prog_. For-    passing an option that contain embedded spaces, such as a file name-    with embedded spaces, using this rather than `--`_`prog`_`-options`-    means you do not need an additional level of quoting. Of course if-    you are using a command shell you may still need to quote, for-    example `--foo-options="--bar=C:\Program File\Bar"`.--All of the options passed with either `--`_`prog`_`-options` or-`--`_`prog`_`-option` are passed in the order they were specified on the-configure command line.--### Installation paths ###--The following options govern the location of installed files from a-package:--`--prefix=`_dir_-:   The root of the installation. For example for a global install you-    might use `/usr/local` on a Unix system, or `C:\Program Files` on a-    Windows system. The other installation paths are usually-    subdirectories of _prefix_, but they don't have to be.--    In the simple build system, _dir_ may contain the following path-    variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`,-    `$arch`, `$abi`, `$abitag`--`--bindir=`_dir_-:   Executables that the user might invoke are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`,-    `$os`, `$arch`, `$abi`, `$abitag--`--libdir=`_dir_-:   Object-code libraries are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--libexecdir=`_dir_-:   Executables that are not expected to be invoked directly by the user-    are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`,-    `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--datadir`=_dir_-:   Architecture-independent data files are installed here.--    In the simple build system, _dir_ may contain the following path-    variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--sysconfdir=`_dir_-:   Installation directory for the configuration files.--    In the simple build system, _dir_ may contain the following path variables:-    `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--In addition the simple build system supports the following installation path options:--`--libsubdir=`_dir_-:   A subdirectory of _libdir_ in which libraries are actually-    installed. For example, in the simple build system on Unix, the-    default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the-    package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so-    libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`.--    _dir_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--datasubdir=`_dir_-:   A subdirectory of _datadir_ in which data files are actually-    installed.--    _dir_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--docdir=`_dir_-:   Documentation files are installed relative to this directory.--    _dir_ may contain the following path variables: `$prefix`, `$bindir`,-    `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--htmldir=`_dir_-:   HTML documentation files are installed relative to this directory.--    _dir_ may contain the following path variables: `$prefix`, `$bindir`,-    `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`,-    `$pkg`, `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--program-prefix=`_prefix_-:   Prepend _prefix_ to installed program names.--    _prefix_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--`--program-suffix=`_suffix_-:   Append _suffix_ to installed program names. The most obvious use for-    this is to append the program's version number to make it possible-    to install several versions of a program at once:-    `--program-suffix='$version'`.--    _suffix_ may contain the following path variables: `$pkgid`, `$pkg`,-    `$version`, `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`--#### Path variables in the simple build system ####--For the simple build system, there are a number of variables that can be-used when specifying installation paths. The defaults are also specified-in terms of these variables. A number of the variables are actually for-other paths, like `$prefix`. This allows paths to be specified relative-to each other rather than as absolute paths, which is important for-building relocatable packages (see [prefix-independence](#prefix-independence)).--`$prefix`-:   The path variable that stands for the root of the installation. For-    an installation to be relocatable, all other installation paths must-    be relative to the `$prefix` variable.--`$bindir`-:   The path variable that expands to the path given by the `--bindir`-    configure option (or the default).--`$libdir`-:   As above but for `--libdir`--`$libsubdir`-:   As above but for `--libsubdir`--`$datadir`-:   As above but for `--datadir`--`$datasubdir`-:   As above but for `--datasubdir`--`$docdir`-:   As above but for `--docdir`--`$pkgid`-:   The name and version of the package, e.g. `mypkg-0.2`--`$pkg`-:   The name of the package, e.g. `mypkg`--`$version`-:   The version of the package, e.g. `0.2`--`$compiler`-:   The compiler being used to build the package, e.g. `ghc-6.6.1`--`$os`-:   The operating system of the computer being used to build the-    package, e.g. `linux`, `windows`, `osx`, `freebsd` or `solaris`--`$arch`-:   The architecture of the computer being used to build the package, e.g.-    `i386`, `x86_64`, `ppc` or `sparc`--`$abitag`-:   An optional tag that a compiler can use for telling incompatible ABI's-    on the same architecture apart. GHCJS encodes the underlying GHC version-    in the ABI tag.--`$abi`-:   A shortcut for getting a path that completely identifies the platform in terms-    of binary compatibility. Expands to the same value as `$arch-$os-compiler-$abitag`-    if the compiler uses an abi tag, `$arch-$os-$compiler` if it doesn't.--#### Paths in the simple build system ####--For the simple build system, the following defaults apply:--Option                     Windows Default                                           Unix Default--------                    ----------------                                          --------------`--prefix` (global)        `C:\Program Files\Haskell`                                `/usr/local`-`--prefix` (per-user)      `C:\Documents And Settings\user\Application Data\cabal`   `$HOME/.cabal`-`--bindir`                 `$prefix\bin`                                             `$prefix/bin`-`--libdir`                 `$prefix`                                                 `$prefix/lib`-`--libsubdir` (others)     `$pkgid\$compiler`                                        `$pkgid/$compiler`-`--libexecdir`             `$prefix\$pkgid`                                          `$prefix/libexec`-`--datadir` (executable)   `$prefix`                                                 `$prefix/share`-`--datadir` (library)      `C:\Program Files\Haskell`                                `$prefix/share`-`--datasubdir`             `$pkgid`                                                  `$pkgid`-`--docdir`                 `$prefix\doc\$pkgid`                                      `$datadir/doc/$pkgid`-`--sysconfdir`             `$prefix\etc`                                             `$prefix/etc`-`--htmldir`                `$docdir\html`                                            `$docdir/html`-`--program-prefix`         (empty)                                                   (empty)-`--program-suffix`         (empty)                                                   (empty)---#### Prefix-independence ####--On Windows it is possible to obtain the pathname of the running program. This-means that we can construct an installable executable package that is-independent of its absolute install location. The executable can find its-auxiliary files by finding its own path and knowing the location of the other-files relative to `$bindir`.  Prefix-independence is particularly useful: it-means the user can choose the install location (i.e. the value of `$prefix`) at-install-time, rather than having to bake the path into the binary when it is-built.--In order to achieve this, we require that for an executable on Windows,-all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with-`$prefix`. If this is not the case then the compiled executable will-have baked-in all absolute paths.--The application need do nothing special to achieve prefix-independence.-If it finds any files using `getDataFileName` and the [other functions-provided for the-purpose](developing-packages.html#accessing-data-files-from-package-code),-the files will be accessed relative to the location of the current-executable.--A library cannot (currently) be prefix-independent, because it will be-linked into an executable whose file system location bears no relation-to the library package.--### Controlling Flag Assignments ###--Flag assignments (see the [resolution of conditions and-flags](developing-packages.html#resolution-of-conditions-and-flags)) can-be controlled with the following command line options.--`-f` _flagname_ or `-f` `-`_flagname_-:   Force the specified flag to `true` or `false` (if preceded with a `-`). Later-    specifications for the same flags will override earlier, i.e.,-    specifying `-fdebug -f-debug` is equivalent to `-f-debug`--`--flags=`_flagspecs_-:   Same as `-f`, but allows specifying multiple flag assignments at-    once. The parameter is a space-separated list of flag names (to-    force a flag to `true`), optionally preceded by a `-` (to force a-    flag to `false`). For example, `--flags="debug -feature1 feature2"` is-    equivalent to `-fdebug -f-feature1 -ffeature2`.--### Building Test Suites ###--`--enable-tests`-:   Build the test suites defined in the package description file during the-    `build` stage. Check for dependencies required by the test suites. If the-    package is configured with this option, it will be possible to run the test-    suites with the `test` command after the package is built.--`--disable-tests`-:   (default) Do not build any test suites during the `build` stage.-    Do not check for dependencies required only by the test suites. It will not-    be possible to invoke the `test` command without reconfiguring the package.--`--enable-coverage`-:   Build libraries and executables (including test suites) with Haskell-    Program Coverage enabled. Running the test suites will automatically-    generate coverage reports with HPC.--`--disable-coverage`-:   (default) Do not enable Haskell Program Coverage.--### Miscellaneous options ##--`--user`-:   Does a per-user installation. This changes the [default installation-    prefix](#paths-in-the-simple-build-system). It also allow-    dependencies to be satisfied by the user's package database, in-    addition to the global database. This also implies a default of-    `--user` for any subsequent `install` command, as packages-    registered in the global database should not depend on packages-    registered in a user's database.--`--global`-:   (default) Does a global installation. In this case package-    dependencies must be satisfied by the global package database. All-    packages in the user's package database will be ignored. Typically-    the final installation step will require administrative privileges.--`--package-db=`_db_-:   Allows package dependencies to be satisfied from this additional-    package database _db_ in addition to the global package database.-    All packages in the user's package database will be ignored. The-    interpretation of _db_ is implementation-specific. Typically it will-    be a file or directory. Not all implementations support arbitrary-    package databases.--`--enable-optimization`[=_n_] or `-O`[_n_]-:   (default) Build with optimization flags (if available). This is-    appropriate for production use, taking more time to build faster-    libraries and programs.--    The optional _n_ value is the optimisation level. Some compilers-    support multiple optimisation levels. The range is 0 to 2. Level 0-    is equivalent to `--disable-optimization`, level 1 is the default if-    no _n_ parameter is given. Level 2 is higher optimisation if the-    compiler supports it. Level 2 is likely to lead to longer compile-    times and bigger generated code.--`--disable-optimization`-:   Build without optimization. This is suited for development: building-    will be quicker, but the resulting library or programs will be slower.--`--enable-library-profiling` or `-p`-:   Request that an additional version of the library with profiling-    features enabled be built and installed (only for implementations-    that support profiling).--`--disable-library-profiling`-:   (default) Do not generate an additional profiling version of the-    library.--`--enable-profiling`-:   Any executables generated should have profiling enabled (only for-    implementations that support profiling). For this to work, all-    libraries used by these executables must also have been built with-    profiling support. The library will be built with profiling enabled (if-    supported) unless `--disable-library-profiling` is specified.--`--disable-profiling`-:   (default) Do not enable profiling in generated executables.--`--enable-library-vanilla`-:   (default) Build ordinary libraries (as opposed to profiling-    libraries). This is independent of the `--enable-library-profiling`-    option. If you enable both, you get both.--`--disable-library-vanilla`-:   Do not build ordinary libraries. This is useful in conjunction with-    `--enable-library-profiling` to build only profiling libraries,-    rather than profiling and ordinary libraries.--`--enable-library-for-ghci`-:   (default) Build libraries suitable for use with GHCi.--`--disable-library-for-ghci`-:   Not all platforms support GHCi and indeed on some platforms, trying-    to build GHCi libs fails. In such cases this flag can be used as a-    workaround.--`--enable-split-objs`-:   Use the GHC `-split-objs` feature when building the library. This-    reduces the final size of the executables that use the library by-    allowing them to link with only the bits that they use rather than-    the entire library. The downside is that building the library takes-    longer and uses considerably more memory.--`--disable-split-objs`-:   (default) Do not use the GHC `-split-objs` feature. This makes-    building the library quicker but the final executables that use the-    library will be larger.--`--enable-executable-stripping`-:   (default) When installing binary executable programs, run the-    `strip` program on the binary. This can considerably reduce the size-    of the executable binary file. It does this by removing debugging-    information and symbols. While such extra information is useful for-    debugging C programs with traditional debuggers it is rarely helpful-    for debugging binaries produced by Haskell compilers.--    Not all Haskell implementations generate native binaries. For such-    implementations this option has no effect.--`--disable-executable-stripping`-:   Do not strip binary executables during installation. You might want-    to use this option if you need to debug a program using gdb, for-    example if you want to debug the C parts of a program containing-    both Haskell and C code. Another reason is if your are building a-    package for a system which has a policy of managing the stripping-    itself (such as some Linux distributions).--`--enable-shared`-:   Build shared library. This implies a separate compiler run to-    generate position independent code as required on most platforms.--`--disable-shared`-:   (default) Do not build shared library.--`--enable-executable-dynamic`-:   Link executables dynamically. The executable's library dependencies should-    be built as shared objects. This implies `--enable-shared` unless-    `--disable-shared` is explicitly specified.--`--disable-executable-dynamic`-:   (default) Link executables statically.--`--configure-option=`_str_-:   An extra option to an external `configure` script, if one is used-    (see the section on [system-dependent-    parameters](developing-packages.html#system-dependent-parameters)).-    There can be several of these options.--`--extra-include-dirs`[=_dir_]-:   An extra directory to search for C header files. You can use this-    flag multiple times to get a list of directories.--    You might need to use this flag if you have standard system header-    files in a non-standard location that is not mentioned in the-    package's `.cabal` file. Using this option has the same affect as-    appending the directory _dir_ to the `include-dirs` field in each-    library and executable in the package's `.cabal` file. The advantage-    of course is that you do not have to modify the package at all.-    These extra directories will be used while building the package and-    for libraries it is also saved in the package registration-    information and used when compiling modules that use the library.--`--extra-lib-dirs`[=_dir_]-:   An extra directory to search for system libraries files. You can use-    this flag multiple times to get a list of directories.--    You might need to use this flag if you have standard system-    libraries in a non-standard location that is not mentioned in the-    package's `.cabal` file. Using this option has the same affect as-    appending the directory _dir_ to the `extra-lib-dirs` field in each-    library and executable in the package's `.cabal` file. The advantage-    of course is that you do not have to modify the package at all.-    These extra directories will be used while building the package and-    for libraries it is also saved in the package registration-    information and used when compiling modules that use the library.--`--allow-newer`[=_pkgs_]-:   Selectively relax upper bounds in dependencies without editing the-    package description.--    If you want to install a package A that depends on B >= 1.0 && < 2.0, but-    you have the version 2.0 of B installed, you can compile A against B 2.0 by-    using `cabal install --allow-newer=B A`. This works for the whole package-    index: if A also depends on C that in turn depends on B < 2.0, C's-    dependency on B will be also relaxed.--    Example:--    ~~~~~~~~~~~~~~~~-    $ cd foo-    $ cabal configure-    Resolving dependencies...-    cabal: Could not resolve dependencies:-    [...]-    $ cabal configure --allow-newer-    Resolving dependencies...-    Configuring foo...-    ~~~~~~~~~~~~~~~~--    Additional examples:--    ~~~~~~~~~~~~~~~~-    # Relax upper bounds in all dependencies.-    $ cabal install --allow-newer foo--    # Relax upper bounds only in dependencies on bar, baz and quux.-    $ cabal install --allow-newer=bar,baz,quux foo--    # Relax the upper bound on bar and force bar==2.1.-    $ cabal install --allow-newer=bar --constraint="bar==2.1" foo-    ~~~~~~~~~~~~~~~~--    It's also possible to enable `--allow-newer` permanently by setting-    `allow-newer: True` in the `~/.cabal/config` file.--`--constraint=`_constraint_-:   Restrict solutions involving a package to a given version range.-    For example, `cabal install --constraint="bar==2.1"` will only consider-    install plans that do not use `bar` at all, or `bar` of version 2.1.--    As a special case, `cabal install --constraint="bar -none"` prevents `bar`-    from being used at all (`-none` abbreviates `> 1 && < 1`); `cabal install-    --constraint="bar installed"` prevents reinstallation of the `bar` package;-    `cabal install --constraint="bar +foo -baz"` specifies that the flag `foo`-    should be turned on and the `baz` flag should be turned off.--## setup build ##--Perform any preprocessing or compilation needed to make this package ready for installation.--This command takes the following options:----_prog_-options=_options_, --_prog_-option=_option_-:   These are mostly the same as the [options configure-    step](#setup-configure). Unlike the options specified at the-    configure step, any program options specified at the build step are-    not persistent but are used for that invocation only. They options-    specified at the build step are in addition not in replacement of-    any options specified at the configure step.--## setup haddock ##--Build the documentation for the package using [haddock][]. By default,-only the documentation for the exposed modules is generated (but see the-`--executables` and `--internal` flags below).--This command takes the following options:--`--hoogle`-:   Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be-    converted by [Hoogle](http://www.haskell.org/hoogle/) into a-    database for searching. This is equivalent to running  [haddock][]-    with the `--hoogle` flag.--`--html-location=`_url_-:   Specify a template for the location of HTML documentation for-    prerequisite packages.  The substitutions ([see-    listing](#paths-in-the-simple-build-system)) are applied to the-    template to obtain a location for each package, which will be used-    by hyperlinks in the generated documentation. For example, the-    following command generates links pointing at [Hackage] pages:--    > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html'--    Here the argument is quoted to prevent substitution by the shell. If-    this option is omitted, the location for each package is obtained-    using the package tool (e.g. `ghc-pkg`).--`--executables`-:   Also run [haddock][] for the modules of all the executable programs.-    By default [haddock][] is run only on the exported modules.--`--internal`-:   Run [haddock][] for the all modules, including unexposed ones, and-    make [haddock][] generate documentation for unexported symbols as-    well.--`--css=`_path_-:   The argument _path_ denotes a CSS file, which is passed to-    [haddock][] and used to set the style of the generated-    documentation. This is only needed to override the default style-    that [haddock][] uses.--`--hyperlink-source`-:   Generate [haddock][] documentation integrated with [HsColour][].-    First, [HsColour][] is run to generate colourised code. Then-    [haddock][] is run to generate HTML documentation.  Each entity-    shown in the documentation is linked to its definition in the-    colourised code.--`--hscolour-css=`_path_-:   The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in--    > runhaskell Setup.hs hscolour --css=_path_--## setup hscolour ##--Produce colourised code in HTML format using [HsColour][]. Colourised-code for exported modules is put in `dist/doc/html/`_pkgid_`/src`.--This command takes the following options:--`--executables`-:   Also run [HsColour][] on the sources of all executable programs.-    Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`.--`--css=`_path_-:   Use the given CSS file for the generated HTML files. The CSS file-    defines the colours used to colourise code. Note that this copies-    the given CSS file to the directory with the generated HTML files-    (renamed to `hscolour.css`) rather than linking to it.--## setup install ##--Copy the files into the install locations and (for library packages)-register the package with the compiler, i.e. make the modules it-contains available to programs.--The [install locations](#installation-paths) are determined by options-to `setup configure`.--This command takes the following options:--`--global`-:   Register this package in the system-wide database. (This is the-    default, unless the `--user` option was supplied to the `configure`-    command.)--`--user`-:   Register this package in the user's local package database. (This is-    the default if the `--user` option was supplied to the `configure`-    command.)--## setup copy ##--Copy the files without registering them.  This command is mainly of use-to those creating binary packages.--This command takes the following option:--`--destdir=`_path_--Specify the directory under which to place installed files.  If this is-not given, then the root directory is assumed.--## setup register ##--Register this package with the compiler, i.e. make the modules it-contains available to programs. This only makes sense for library-packages. Note that the `install` command incorporates this action.  The-main use of this separate command is in the post-installation step for a-binary package.--This command takes the following options:--`--global`-:   Register this package in the system-wide database. (This is the default.)---`--user`-:   Register this package in the user's local package database.---`--gen-script`-:   Instead of registering the package, generate a script containing-    commands to perform the registration.  On Unix, this file is called-    `register.sh`, on Windows, `register.bat`.  This script might be-    included in a binary bundle, to be run after the bundle is unpacked-    on the target system.--`--gen-pkg-config`[=_path_]-:   Instead of registering the package, generate a package registration-    file. This only applies to compilers that support package-    registration files which at the moment is only GHC. The file should-    be used with the compiler's mechanism for registering packages. This-    option is mainly intended for packaging systems. If possible use the-    `--gen-script` option instead since it is more portable across-    Haskell implementations. The _path_ is-    optional and can be used to specify a particular output file to-    generate. Otherwise, by default the file is the package name and-    version with a `.conf` extension.--`--inplace`-:   Registers the package for use directly from the build tree, without-    needing to install it.  This can be useful for testing: there's no-    need to install the package after modifying it, just recompile and-    test.--    This flag does not create a build-tree-local package database.  It-    still registers the package in one of the user or global databases.--    However, there are some caveats.  It only works with GHC-    (currently).  It only works if your package doesn't depend on having-    any supplemental files installed --- plain Haskell libraries should-    be fine.--## setup unregister ##--Deregister this package with the compiler.--This command takes the following options:--`--global`-:   Deregister this package in the system-wide database. (This is the default.)--`--user`-:   Deregister this package in the user's local package database.--`--gen-script`-:   Instead of deregistering the package, generate a script containing-    commands to perform the deregistration.  On Unix, this file is-    called `unregister.sh`, on Windows, `unregister.bat`. This script-    might be included in a binary bundle, to be run on the target-    system.--## setup clean ##--Remove any local files created during the `configure`, `build`,-`haddock`, `register` or `unregister` steps, and also any files and-directories listed in the `extra-tmp-files` field.--This command takes the following options:--`--save-configure` or `-s`-:   Keeps the configuration information so it is not necessary to run-    the configure step again before building.--## setup test ##--Run the test suites specified in the package description file.  Aside from-the following flags, Cabal accepts the name of one or more test suites on the-command line after `test`.  When supplied, Cabal will run only the named test-suites, otherwise, Cabal will run all test suites in the package.--`--builddir=`_dir_-:   The directory where Cabal puts generated build files (default: `dist`).-    Test logs will be located in the `test` subdirectory.--`--human-log=`_path_-:   The template used to name human-readable test logs; the path is relative-    to `dist/test`.  By default, logs are named according to the template-    `$pkgid-$test-suite.log`, so that each test suite will be logged to its own-    human-readable log file.  Template variables allowed are: `$pkgid`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag`, `$test-suite`, and `$result`.--`--machine-log=`_path_-:   The path to the machine-readable log, relative to `dist/test`.  The default-    template is `$pkgid.log`.  Template variables allowed are: `$pkgid`,-    `$compiler`, `$os`, `$arch`, `$abi`, `$abitag` and `$result`.--`--show-details=`_filter_-:   Determines if the results of individual test cases are shown on the-    terminal.  May be `always` (always show), `never` (never show), `failures`-    (show only failed results), or `streaming` (show all results in real time).--`--test-options=`_options_-:   Give extra options to the test executables.--`--test-option=`_option_-:   give an extra option to the test executables.  There is no need to quote-    options containing spaces because a single option is assumed, so options-    will not be split on spaces.--## setup sdist ##--Create a system- and compiler-independent source distribution in a file-_package_-_version_`.tar.gz` in the `dist` subdirectory, for-distribution to package builders.  When unpacked, the commands listed in-this section will be available.--The files placed in this distribution are the package description file,-the setup script, the sources of the modules named in the package-description file, and files named in the `license-file`, `main-is`,-`c-sources`, `js-sources`, `data-files`, `extra-source-files` and-`extra-doc-files` fields.--This command takes the following option:--`--snapshot`-:   Append today's date (in "YYYYMMDD" format) to the version number for-    the generated source package.  The original package is unaffected.---[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/
− doc/misc.markdown 
@@ -1,109 +0,0 @@-% Cabal User Guide--# Reporting bugs and deficiencies #--Please report any flaws or feature requests in the [bug tracker][].--For general discussion or queries email the libraries mailing list-<libraries@haskell.org>. There is also a development mailing list-<cabal-devel@haskell.org>.--[bug tracker]: https://github.com/haskell/cabal/issues--# Stability of Cabal interfaces #--The Cabal library and related infrastructure is still under active-development. New features are being added and limitations and bugs are-being fixed. This requires internal changes and often user visible-changes as well. We therefore cannot promise complete future-proof-stability, at least not without halting all development work.--This section documents the aspects of the Cabal interface that we can-promise to keep stable and which bits are subject to change.--## Cabal file format ##--This is backwards compatible and mostly forwards compatible. New fields-can be added without breaking older versions of Cabal. Fields can be-deprecated without breaking older packages.--## Command-line interface ##--### Very Stable Command-line interfaces ###--* `./setup configure`-  * `--prefix`-  * `--user`-  * `--ghc`, `--uhc`-  * `--verbose`-  * `--prefix`--* `./setup build`-* `./setup install`-* `./setup register`-* `./setup copy`--### Stable Command-line interfaces ###--### Unstable command-line ###--## Functions and Types ##--The Cabal library follows the [Package Versioning Policy][PVP]. This-means that within a stable major release, for example 1.2.x, there will-be no incompatible API changes. But minor versions increments, for-example 1.2.3, indicate compatible API additions.--The Package Versioning Policy does not require any API guarantees-between major releases, for example between 1.2.x and 1.4.x. In practise-of course not everything changes between major releases. Some parts of-the API are more prone to change than others. The rest of this section-gives some informal advice on what level of API stability you can expect-between major releases.--[PVP]: http://www.haskell.org/haskellwiki/Package_versioning_policy--### Very Stable API ###--* `defaultMain`--* `defaultMainWithHooks defaultUserHooks`--  But regular `defaultMainWithHooks` isn't stable since `UserHooks`-  changes.--### Semi-stable API ###--* `UserHooks` The hooks API will change in the future--* `Distribution.*` is mostly declarative information about packages and-   is somewhat stable.--### Unstable API ###--Everything under `Distribution.Simple.*` has no stability guarantee.--## Hackage ##--The index format is a partly stable interface. It consists of a tar.gz-file that contains directories with `.cabal` files in. In future it may-contain more kinds of files so do not assume every file is a `.cabal`-file. Incompatible revisions to the format would involve bumping the-name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc.---[dist-simple]:  ../release/cabal-latest/doc/API/Cabal/Distribution-Simple.html-[dist-make]:    ../release/cabal-latest/doc/API/Cabal/Distribution-Make.html-[dist-license]: ../release/cabal-latest/doc/API/Cabal/Distribution-License.html#t:License-[extension]:    ../release/cabal-latest/doc/API/Cabal/Language-Haskell-Extension.html#t:Extension-[BuildType]:    ../release/cabal-latest/doc/API/Cabal/Distribution-PackageDescription.html#t:BuildType-[alex]:       http://www.haskell.org/alex/-[autoconf]:   http://www.gnu.org/software/autoconf/-[c2hs]:       http://www.cse.unsw.edu.au/~chak/haskell/c2hs/-[cpphs]:      http://projects.haskell.org/cpphs/-[greencard]:  http://hackage.haskell.org/package/greencard-[haddock]:    http://www.haskell.org/haddock/-[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/-[happy]:      http://www.haskell.org/happy/-[Hackage]:    http://hackage.haskell.org/-[pkg-config]: http://www.freedesktop.org/wiki/Software/pkg-config/
+ 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.hs 
@@ -1,172 +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 PackageTests.BenchmarkExeV10.Check-import PackageTests.BenchmarkOptions.Check-import PackageTests.BenchmarkStanza.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.BuildDeps.SameDepsAllRound.Check-import PackageTests.BuildDeps.TargetSpecificDeps1.Check-import PackageTests.BuildDeps.TargetSpecificDeps2.Check-import PackageTests.BuildDeps.TargetSpecificDeps3.Check-import PackageTests.BuildTestSuiteDetailedV09.Check-import PackageTests.PackageTester (PackageSpec(..), compileSetup)-import PackageTests.PathsModule.Executable.Check-import PackageTests.PathsModule.Library.Check-import PackageTests.PreProcess.Check-import PackageTests.TemplateHaskell.Check-import PackageTests.CMain.Check-import PackageTests.DeterministicAr.Check-import PackageTests.EmptyLib.Check-import PackageTests.Haddock.Check-import PackageTests.TestOptions.Check-import PackageTests.TestStanza.Check-import PackageTests.TestSuiteExeV10.Check-import PackageTests.OrderFlags.Check-import PackageTests.ReexportedModules.Check--import Distribution.Simple.Configure-    ( ConfigStateFileError(..), getConfigStateFile )-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))-import Distribution.Simple.Program.Types (programPath)-import Distribution.Simple.Program.Builtin-    ( ghcProgram, ghcPkgProgram, haddockProgram )-import Distribution.Simple.Program.Db (requireProgram)-import Distribution.Simple.Utils (cabalVersion)-import Distribution.Text (display)-import Distribution.Verbosity (normal)-import Distribution.Version (Version(Version))--import Control.Exception (try, throw)-import System.Directory-    ( getCurrentDirectory, setCurrentDirectory )-import System.FilePath ((</>))-import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)-import Test.Framework (Test, TestName, defaultMain, testGroup)-import Test.Framework.Providers.HUnit (hUnitTestToTests)-import qualified Test.HUnit as HUnit---hunit :: TestName -> HUnit.Test -> Test-hunit name test = testGroup name $ hUnitTestToTests test--tests :: Version -> PackageSpec -> FilePath -> FilePath -> [Test]-tests version inplaceSpec ghcPath ghcPkgPath =-    [ hunit "BuildDeps/SameDepsAllRound"-      (PackageTests.BuildDeps.SameDepsAllRound.Check.suite ghcPath)-      -- The two following tests were disabled by Johan Tibell as-      -- they have been failing for a long time:-      -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive1/"-      --   (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite ghcPath)-      -- , hunit "BuildDeps/GlobalBuildDepsNotAdditive2/"-      --   (PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite ghcPath)-    , hunit "BuildDeps/InternalLibrary0"-      (PackageTests.BuildDeps.InternalLibrary0.Check.suite version ghcPath)-    , hunit "PreProcess" (PackageTests.PreProcess.Check.suite ghcPath)-    , hunit "TestStanza" (PackageTests.TestStanza.Check.suite ghcPath)-      -- ^ The Test stanza test will eventually be required-      -- only for higher versions.-    , testGroup "TestSuiteExeV10" (PackageTests.TestSuiteExeV10.Check.checks ghcPath)-    , hunit "TestOptions" (PackageTests.TestOptions.Check.suite ghcPath)-    , hunit "BenchmarkStanza" (PackageTests.BenchmarkStanza.Check.suite ghcPath)-      -- ^ The benchmark stanza test will eventually be required-      -- only for higher versions.-    , hunit "BenchmarkExeV10/Test"-      (PackageTests.BenchmarkExeV10.Check.checkBenchmark ghcPath)-    , hunit "BenchmarkOptions" (PackageTests.BenchmarkOptions.Check.suite ghcPath)-    , hunit "TemplateHaskell/vanilla"-      (PackageTests.TemplateHaskell.Check.vanilla ghcPath)-    , hunit "TemplateHaskell/profiling"-      (PackageTests.TemplateHaskell.Check.profiling ghcPath)-    , hunit "PathsModule/Executable"-      (PackageTests.PathsModule.Executable.Check.suite ghcPath)-    , hunit "PathsModule/Library" (PackageTests.PathsModule.Library.Check.suite ghcPath)-    , hunit "DeterministicAr"-        (PackageTests.DeterministicAr.Check.suite ghcPath ghcPkgPath)-    , hunit "EmptyLib/emptyLib"-      (PackageTests.EmptyLib.Check.emptyLib ghcPath)-    , hunit "Haddock" (PackageTests.Haddock.Check.suite ghcPath)-    , hunit "BuildTestSuiteDetailedV09"-      (PackageTests.BuildTestSuiteDetailedV09.Check.suite inplaceSpec ghcPath)-    , hunit "OrderFlags"-      (PackageTests.OrderFlags.Check.suite ghcPath)-    , hunit "TemplateHaskell/dynamic"-      (PackageTests.TemplateHaskell.Check.dynamic ghcPath)-    , hunit "ReexportedModules"-      (PackageTests.ReexportedModules.Check.suite ghcPath)-    ] ++-    -- These tests are only required to pass on cabal version >= 1.7-    (if version >= Version [1, 7] []-     then [ hunit "BuildDeps/TargetSpecificDeps1"-            (PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite ghcPath)-          , hunit "BuildDeps/TargetSpecificDeps2"-            (PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite ghcPath)-          , hunit "BuildDeps/TargetSpecificDeps3"-            (PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite ghcPath)-          , hunit "BuildDeps/InternalLibrary1"-            (PackageTests.BuildDeps.InternalLibrary1.Check.suite ghcPath)-          , hunit "BuildDeps/InternalLibrary2"-            (PackageTests.BuildDeps.InternalLibrary2.Check.suite ghcPath ghcPkgPath)-          , hunit "BuildDeps/InternalLibrary3"-            (PackageTests.BuildDeps.InternalLibrary3.Check.suite ghcPath ghcPkgPath)-          , hunit "BuildDeps/InternalLibrary4"-            (PackageTests.BuildDeps.InternalLibrary4.Check.suite ghcPath ghcPkgPath)-          , hunit "PackageTests/CMain"-            (PackageTests.CMain.Check.checkBuild ghcPath)-          ]-     else [])--main :: IO ()-main = do-    -- WORKAROUND: disable buffering on stdout to get streaming test logs-    -- test providers _should_ do this themselves-    hSetBuffering stdout NoBuffering--    wd <- getCurrentDirectory-    let dbFile = wd </> "dist/package.conf.inplace"-        inplaceSpec = PackageSpec-            { directory = []-            , configOpts = [ "--package-db=" ++ dbFile-                           , "--constraint=Cabal == " ++ display cabalVersion-                           ]-            , distPref = Nothing-            }-    putStrLn $ "Cabal test suite - testing cabal version " ++-        display cabalVersion-    lbi <- getPersistBuildConfig_ ("dist" </> "setup-config")-    (ghc, _) <- requireProgram normal ghcProgram (withPrograms lbi)-    (ghcPkg, _) <- requireProgram normal ghcPkgProgram (withPrograms lbi)-    (haddock, _) <- requireProgram normal haddockProgram (withPrograms lbi)-    let ghcPath = programPath ghc-        ghcPkgPath = programPath ghcPkg-        haddockPath = programPath haddock-    putStrLn $ "Using ghc: " ++ ghcPath-    putStrLn $ "Using ghc-pkg: " ++ ghcPkgPath-    putStrLn $ "Using haddock: " ++ haddockPath-    setCurrentDirectory "tests"-    -- Create a shared Setup executable to speed up Simple tests-    compileSetup "." ghcPath-    defaultMain (tests cabalVersion inplaceSpec ghcPath ghcPkgPath)---- Like Distribution.Simple.Configure.getPersistBuildConfig but--- doesn't check that the Cabal version matches, which it doesn't when--- we run Cabal's own test suite, due to bootstrapping issues.-getPersistBuildConfig_ :: FilePath -> IO LocalBuildInfo-getPersistBuildConfig_ filename = do-    eLBI <- try $ getConfigStateFile filename-    case eLBI of-      Left (ConfigStateFileBadVersion _ _ (Right lbi)) -> return lbi-      Left (ConfigStateFileBadVersion _ _ (Left err)) -> throw err-      Left err -> throw err-      Right lbi -> return lbi
− tests/PackageTests/BenchmarkExeV10/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.BenchmarkExeV10.Check-       ( checkBenchmark-       ) where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit--dir :: FilePath-dir = "PackageTests" </> "BenchmarkExeV10"--checkBenchmark :: FilePath -> Test-checkBenchmark ghcPath = TestCase $ do-    let spec = PackageSpec dir Nothing ["--enable-benchmarks"]-    buildResult <- cabal_build spec ghcPath-    assertBuildSucceeded buildResult
− tests/PackageTests/BenchmarkExeV10/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--fooTest :: [String] -> Bool-fooTest _ = True
− tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs 
@@ -1,8 +0,0 @@-module Main where--import Foo-import System.Exit--main :: IO ()-main | fooTest [] = exitSuccess-     | otherwise = exitFailure
− tests/PackageTests/BenchmarkExeV10/my.cabal 
@@ -1,15 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.9.2-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base--benchmark bench-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: benchmarks-    main-is:    bench-Foo.hs-    build-depends: base, my
− tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal 
@@ -1,20 +0,0 @@-name: BenchmarkOptions-version: 0.1-license: BSD3-author: Johan Tibell-stability: stable-category: PackageTests-build-type: Simple-cabal-version: >= 1.9.2--description:-    Check that Cabal passes the correct test options to test suites.--executable dummy-    main-is: test-BenchmarkOptions.hs-    build-depends: base--benchmark test-BenchmarkOptions-    main-is: test-BenchmarkOptions.hs-    type: exitcode-stdio-1.0-    build-depends: base
− tests/PackageTests/BenchmarkOptions/Check.hs 
@@ -1,26 +0,0 @@-module PackageTests.BenchmarkOptions.Check where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BenchmarkOptions"-            , configOpts = ["--enable-benchmarks"]-            , distPref = Nothing-            }-    _ <- cabal_build spec ghcPath-    result <- cabal_bench spec ["--benchmark-options=1 2 3"] ghcPath-    let message = "\"cabal bench\" did not pass the correct options to the "-                  ++ "benchmark executable with \"--benchmark-options\""-    assertEqual message True $ successful result-    result' <- cabal_bench spec [ "--benchmark-option=1"-                                , "--benchmark-option=2"-                                , "--benchmark-option=3"-                                ]-               ghcPath-    let message' = "\"cabal bench\" did not pass the correct options to the "-                   ++ "benchmark executable with \"--benchmark-option\""-    assertEqual message' True $ successful result'
− tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs 
@@ -1,11 +0,0 @@-module Main where--import System.Environment ( getArgs )-import System.Exit ( exitFailure, exitSuccess )--main :: IO ()-main = do-    args <- getArgs-    if args == ["1", "2", "3"]-        then exitSuccess-        else putStrLn ("Got: " ++ show args) >> exitFailure
− tests/PackageTests/BenchmarkStanza/Check.hs 
@@ -1,52 +0,0 @@-module PackageTests.BenchmarkStanza.Check where--import Test.HUnit-import System.FilePath-import qualified Data.Map as Map-import PackageTests.PackageTester-import Distribution.Version-import Distribution.PackageDescription.Parse-        ( readPackageDescription )-import Distribution.PackageDescription.Configuration-        ( finalizePackageDescription )-import Distribution.Package-        ( PackageName(..), Dependency(..) )-import Distribution.PackageDescription-        ( PackageDescription(..), BuildInfo(..), Benchmark(..)-        , BenchmarkInterface(..)-        , emptyBuildInfo-        , emptyBenchmark, defaultRenaming )-import Distribution.Verbosity (silent)-import Distribution.System (buildPlatform)-import Distribution.Compiler-        ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) )-import Distribution.Text--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let dir = "PackageTests" </> "BenchmarkStanza"-        pdFile = dir </> "my" <.> "cabal"-        spec = PackageSpec { directory = dir, configOpts = [], distPref = Nothing }-    result <- cabal_configure spec ghcPath-    assertOutputDoesNotContain "unknown section type" result-    genPD <- readPackageDescription silent pdFile-    let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag-        anticipatedBenchmark = emptyBenchmark-            { benchmarkName = "dummy"-            , benchmarkInterface = BenchmarkExeV10 (Version [1,0] []) "dummy.hs"-            , benchmarkBuildInfo = emptyBuildInfo-                    { targetBuildDepends =-                            [ Dependency (PackageName "base") anyVersion ]-                    , targetBuildRenaming =-                            Map.singleton (PackageName "base") defaultRenaming-                    , 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/BenchmarkStanza/my.cabal 
@@ -1,19 +0,0 @@-name: BenchmarkStanza-version: 0.1-license: BSD3-author: Johan Tibell-stability: stable-category: PackageTests-build-type: Simple--description:-    Check that Cabal recognizes the benchmark stanza defined below.--Library-    exposed-modules: MyLibrary-    build-depends: base--benchmark dummy-    main-is: dummy.hs-    type: exitcode-stdio-1.0-    build-depends: base
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 
@@ -1,22 +0,0 @@-module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List-import Control.Exception-import Prelude hiding (catch)---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []-    result <- cabal_build spec ghcPath-    do-        assertEqual "cabal build should fail - see test-log.txt" False (successful result)-        let sb = "Could not find module `Prelude'"-        assertBool ("cabal output should be "++show sb) $-            sb `isInfixOf` outputText result-      `catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 
@@ -1,20 +0,0 @@-name: GlobalBuildDepsNotAdditive1-version: 0.1-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    If you specify 'base' in the global build dependencies, then define-    a library without base, it fails to find 'base' for the library.-------------------------------------------build-depends: base--Library-    exposed-modules: MyLibrary-    build-depends: bytestring, old-time
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 
@@ -1,22 +0,0 @@-module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List-import Control.Exception-import Prelude hiding (catch)---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []-    result <- cabal_build spec ghcPath-    do-        assertEqual "cabal build should fail - see test-log.txt" False (successful result)-        let sb = "Could not find module `Prelude'"-        assertBool ("cabal output should be "++show sb) $-            sb `isInfixOf` outputText result-      `catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 
@@ -1,20 +0,0 @@-name: GlobalBuildDepsNotAdditive1-version: 0.1-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    If you specify 'base' in the global build dependencies, then define-    an executable without base, it fails to find 'base' for the executable-------------------------------------------build-depends: base--Executable lemon-    main-is: lemon.hs-    build-depends: bytestring, old-time
− tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 
@@ -1,7 +0,0 @@-import qualified Data.ByteString.Char8 as C-import System.Time--main = do-    getClockTime-    let text = "lemon"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 
@@ -1,22 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary0.Check where--import Control.Monad-import Data.Version-import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---suite :: Version -> FilePath -> Test-suite cabalVersion ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary0"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    assertBuildFailed result-    when (cabalVersion >= Version [1, 7] []) $ do-        let sb = "library which is defined within the same package."-        -- In 1.7 it should tell you how to enable the desired behaviour.-        assertOutputContains sb result
− tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 
@@ -1,24 +0,0 @@-name: InternalLibrary0-version: 0.1-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    Check that with 'cabal-version:' containing versions less than 1.7, we do *not*-    have the new behaviour to allow executables to refer to the library defined-    in the same module.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    hs-source-dirs: programs-    build-depends: base, bytestring, old-time, InternalLibrary0
− tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary1.Check where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary1"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    assertBuildSucceeded result
− tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 
@@ -1,23 +0,0 @@-name: InternalLibrary1-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    Check for the new (in >= 1.7.1) ability to allow executables to refer to-    the library defined in the same module.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    hs-source-dirs: programs-    build-depends: base, bytestring, old-time, InternalLibrary1
− tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 
@@ -1,32 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary2.Check where--import qualified Data.ByteString.Char8 as C-import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---suite :: FilePath -> FilePath -> Test-suite ghcPath ghcPkgPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary2"-            , configOpts = []-            , distPref = Nothing-            }-    let specTI = PackageSpec-            { directory = directory spec </> "to-install"-            , configOpts = []-            , distPref = Nothing-            }--    unregister "InternalLibrary2" ghcPkgPath-    iResult <- cabal_install specTI ghcPath-    assertInstallSucceeded iResult-    bResult <- cabal_build spec ghcPath-    assertBuildSucceeded bResult-    unregister "InternalLibrary2" ghcPkgPath--    (_, _, output) <- run (Just $ directory spec) (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/InternalLibrary2/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc internal"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 
@@ -1,23 +0,0 @@-name: InternalLibrary2-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that the internal library is preferred by ghc to-    an installed one of the same name and version.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    hs-source-dirs: programs-    build-depends: base, bytestring, old-time, InternalLibrary2
− tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc installed"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 
@@ -1,18 +0,0 @@-name: InternalLibrary2-version: 0.1-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that the internal library is preferred by ghc to-    an installed one of the same name and version.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time
− tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 
@@ -1,32 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary3.Check where--import qualified Data.ByteString.Char8 as C-import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---suite :: FilePath -> FilePath -> Test-suite ghcPath ghcPkgPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary3"-            , configOpts = []-            , distPref = Nothing-            }-    let specTI = PackageSpec-            { directory = directory spec </> "to-install"-            , configOpts = []-            , distPref = Nothing-            }--    unregister "InternalLibrary3" ghcPkgPath-    iResult <- cabal_install specTI ghcPath-    assertInstallSucceeded iResult-    bResult <- cabal_build spec ghcPath-    assertBuildSucceeded bResult-    unregister "InternalLibrary3"ghcPkgPath--    (_, _, output) <- run (Just $ directory spec) (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/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc internal"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 
@@ -1,23 +0,0 @@-name: InternalLibrary3-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that the internal library is preferred by ghc to-    an installed one of the same name, but a *newer* version.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    hs-source-dirs: programs-    build-depends: base, bytestring, old-time, InternalLibrary3
− tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc installed"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 
@@ -1,18 +0,0 @@-name: InternalLibrary3-version: 0.2-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that the internal library is preferred by ghc to-    an installed one of the same name but a *newer* version.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time
− tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 
@@ -1,32 +0,0 @@-module PackageTests.BuildDeps.InternalLibrary4.Check where--import qualified Data.ByteString.Char8 as C-import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---suite :: FilePath -> FilePath -> Test-suite ghcPath ghcPkgPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "InternalLibrary4"-            , configOpts = []-            , distPref = Nothing-            }-    let specTI = PackageSpec-            { directory = directory spec </> "to-install"-            , configOpts = []-            , distPref = Nothing-            }--    unregister "InternalLibrary4" ghcPkgPath-    iResult <- cabal_install specTI ghcPath-    assertInstallSucceeded iResult-    bResult <- cabal_build spec ghcPath-    assertBuildSucceeded bResult-    unregister "InternalLibrary4" ghcPkgPath--    (_, _, output) <- run (Just $ directory spec) (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/InternalLibrary4/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc internal"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 
@@ -1,23 +0,0 @@-name: InternalLibrary4-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that we can explicitly say we want InternalLibrary4-0.2-    and it will give us the *installed* version 0.2 instead of the internal 0.1.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    hs-source-dirs: programs-    build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2
− tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 
@@ -1,6 +0,0 @@-import System.Time-import MyLibrary--main = do-    getClockTime-    myLibFunc
− tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc installed"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 
@@ -1,18 +0,0 @@-name: InternalLibrary4-version: 0.2-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    This test is to make sure that the internal library is preferred by ghc to-    an installed one of the same name but a *newer* version.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time
− tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 
@@ -1,21 +0,0 @@-module PackageTests.BuildDeps.SameDepsAllRound.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import qualified Control.Exception as E---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "SameDepsAllRound"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    do-        assertEqual "cabal build should succeed - see test-log.txt" True (successful result)-      `E.catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        E.throwIO (exc :: E.SomeException)
− tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 
@@ -1,31 +0,0 @@-name: SameDepsAllRound-version: 0.1-license: BSD3-cabal-version: >= 1.6-author: Stephen Blackheath-stability: stable-synopsis: Same dependencies all round-category: PackageTests-build-type: Simple--description:-    Check for the "old build-dep behaviour" namely that we get the same-    package dependencies on all build targets, even if different ones-    were specified for different targets-    .-    Here all .hs files use the three packages mentioned, so this shows-    that build-depends is not target-specific.  This is the behaviour-    we want when cabal-version contains versions less than 1.7.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring--Executable lemon-    main-is: lemon.hs-    build-depends: old-time--Executable pineapple-    main-is: pineapple.hs
− tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 
@@ -1,7 +0,0 @@-import qualified Data.ByteString.Char8 as C-import System.Time--main = do-    getClockTime-    let text = "lemon"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 
@@ -1,7 +0,0 @@-import qualified Data.ByteString.Char8 as C-import System.Time--main = do-    getClockTime-    let text = "pineapple"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 
@@ -1,29 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps1.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List-import qualified Control.Exception as E-import Text.Regex.Posix---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    do-        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\"" $-            (intercalate " " $ lines $ outputText result)-            =~ "Could not find module.*System.Time"--      `E.catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        E.throwIO (exc :: E.SomeException)
− tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 
@@ -1,7 +0,0 @@-import qualified Data.ByteString.Char8 as C-import System.Time--main = do-    getClockTime-    let text = "lemon"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 
@@ -1,22 +0,0 @@-name: TargetSpecificDeps1-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    Check for the new build-dep behaviour, where build-depends are-    handled specifically for each target-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring--Executable lemon-    main-is: lemon.hs-    build-depends: base, bytestring, old-time
− tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 
@@ -1,21 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps2.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import qualified Control.Exception as E---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    do-        assertEqual "cabal build should succeed - see test-log.txt" True (successful result)-      `E.catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        E.throwIO (exc :: E.SomeException)
− tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 
@@ -1,5 +0,0 @@-import qualified Data.ByteString.Char8 as C--main = do-    let text = "lemon"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 
@@ -1,24 +0,0 @@-name: TargetSpecificDeps1-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    Check for the new build-dep behaviour, where build-depends are-    handled specifically for each target-    This one is a control against TargetSpecificDeps1 - it is correct and should-    succeed.-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    build-depends: base, bytestring
− tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 
@@ -1,28 +0,0 @@-module PackageTests.BuildDeps.TargetSpecificDeps3.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Data.List-import qualified Control.Exception as E-import Text.Regex.Posix---suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    do-        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\"" $-            (intercalate " " $ lines $ outputText result)-            =~ "Could not find module.*System.Time"-      `E.catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        E.throwIO (exc :: E.SomeException)
− tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 
@@ -1,10 +0,0 @@-module MyLibrary where--import qualified Data.ByteString.Char8 as C-import System.Time--myLibFunc :: IO ()-myLibFunc = do-    getClockTime-    let text = "myLibFunc"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 
@@ -1,7 +0,0 @@-import qualified Data.ByteString.Char8 as C-import System.Time--main = do-    getClockTime-    let text = "lemon"-    C.putStrLn $ C.pack text
− tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 
@@ -1,22 +0,0 @@-name: test-version: 0.1-license: BSD3-cabal-version: >= 1.7.1-author: Stephen Blackheath-stability: stable-category: PackageTests-build-type: Simple--description:-    Check for the new build-dep behaviour, where build-depends are-    handled specifically for each target-------------------------------------------Library-    exposed-modules: MyLibrary-    build-depends: base, bytestring, old-time--Executable lemon-    main-is: lemon.hs-    build-depends: base, bytestring
− tests/PackageTests/BuildTestSuiteDetailedV09/Check.hs 
@@ -1,18 +0,0 @@-module PackageTests.BuildTestSuiteDetailedV09.Check where--import Test.HUnit-import System.FilePath ((</>))--import PackageTests.PackageTester--suite :: PackageSpec -> FilePath -> Test-suite inplaceSpec ghcPath = TestCase $ do-    let dir = "PackageTests" </> "BuildTestSuiteDetailedV09"-        spec = inplaceSpec-            { directory = dir-            , configOpts = "--enable-tests" : configOpts inplaceSpec-            }-    confResult <- cabal_configure spec ghcPath-    assertEqual "configure failed!" (successful confResult) True-    buildResult <- cabal_build spec ghcPath-    assertEqual "build failed!" (successful buildResult) True
− tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs 
@@ -1,6 +0,0 @@-module Dummy where--import Distribution.TestSuite (Test)--tests :: IO [Test]-tests = return []
− tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal 
@@ -1,19 +0,0 @@-name: BuildTestSuiteDetailedV09-version: 0.1-license: BSD3-author: Thomas Tuegel-stability: stable-category: PackageTests-build-type: Simple--description:-    Check that Cabal can build test suites of type detailed-0.9.--Library-    exposed-modules: Dummy-    build-depends: base, Cabal--test-suite test-Dummy-  type:       detailed-0.9-  test-module: Dummy-  build-depends: base, Cabal
− tests/PackageTests/CMain/Bar.hs 
@@ -1,7 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-module Bar where--bar :: IO ()-bar = return ()--foreign export ccall bar :: IO ()
− tests/PackageTests/CMain/Check.hs 
@@ -1,20 +0,0 @@-module PackageTests.CMain.Check-       ( checkBuild-       ) where--import Test.HUnit-import System.FilePath-import PackageTests.PackageTester--dir :: FilePath-dir = "PackageTests" </> "CMain"--checkBuild :: FilePath -> Test-checkBuild ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = dir-            , distPref = Nothing-            , configOpts = []-            }-    buildResult <- cabal_build spec ghcPath-    assertBuildSucceeded buildResult
− tests/PackageTests/CMain/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− tests/PackageTests/CMain/foo.c 
@@ -1,13 +0,0 @@-#include <stdio.h>-#include "HsFFI.h"--#ifdef __GLASGOW_HASKELL__-#include "Bar_stub.h"-#endif--int main(int argc, char **argv) {-    hs_init(&argc, &argv);-    bar();-    printf("Hello world!");-    return 0;-}
− tests/PackageTests/CMain/my.cabal 
@@ -1,10 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.9.2-build-type:     Simple--executable foo-    main-is:    foo.c-    other-modules: Bar-    build-depends: base
− tests/PackageTests/DeterministicAr/Check.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE CPP               #-}-{-# LANGUAGE OverloadedStrings #-}--module PackageTests.DeterministicAr.Check where--import Control.Monad-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BS8-import Data.Char (isSpace)-import Data.List-#if __GLASGOW_HASKELL__ < 710-import Data.Traversable-#endif-import PackageTests.PackageTester-import System.Exit-import System.FilePath-import System.IO-import Test.HUnit (Assertion, Test (TestCase), assertFailure)--import Distribution.Compiler              (CompilerFlavor(..), CompilerId(..))-import Distribution.Package               (packageKeyHash)-import Distribution.Version               (Version(..))-import Distribution.Simple.Compiler       (compilerId)-import Distribution.Simple.Configure      (getPersistBuildConfig)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, compiler, pkgKey)---- Perhaps these should live in PackageTester.---- For a polymorphic @IO a@ rather than @Assertion = IO ()@.-assertFailure' :: String -> IO a-assertFailure' msg = assertFailure msg >> return {-unpossible!-}undefined--ghcPkg_field :: String -> String -> FilePath -> IO [FilePath]-ghcPkg_field libraryName fieldName ghcPkgPath = do-    (cmd, exitCode, raw) <- run Nothing ghcPkgPath []-        ["--user", "field", libraryName, fieldName]-    let output = filter ('\r' /=) raw -- Windows-    -- copypasta of PackageTester.requireSuccess-    unless (exitCode == ExitSuccess) . assertFailure $-        "Command " ++ cmd ++ " failed.\n" ++ "output: " ++ output--    let prefix = fieldName ++ ": "-    case traverse (stripPrefix prefix) (lines output) of-        Nothing -> assertFailure' $ "Command " ++ cmd ++ " failed: expected "-            ++ show prefix ++ " prefix on every line.\noutput: " ++ output-        Just fields -> return fields--ghcPkg_field1 :: String -> String -> FilePath -> IO FilePath-ghcPkg_field1 libraryName fieldName ghcPkgPath = do-    fields <- ghcPkg_field libraryName fieldName ghcPkgPath-    case fields of-        [field] -> return field-        _ -> assertFailure' $ "Command ghc-pkg field failed: "-            ++ "output not a single line.\noutput: " ++ show fields----------------------------------------------------------------------------this :: String-this = "DeterministicAr"--suite :: FilePath -> FilePath -> Test-suite ghcPath ghcPkgPath = TestCase $ do-    let dir = "PackageTests" </> this-    let spec = PackageSpec-            { directory = dir-            , configOpts = []-            , distPref = Nothing-            }--    unregister this ghcPkgPath-    iResult <- cabal_install spec ghcPath-    assertInstallSucceeded iResult--    let distBuild = dir </> "dist" </> "build"-    libdir <- ghcPkg_field1 this "library-dirs" ghcPkgPath-    lbi    <- getPersistBuildConfig (dir </> "dist")-    mapM_ (checkMetadata lbi) [distBuild, libdir]-    unregister this ghcPkgPath---- Almost a copypasta of Distribution.Simple.Program.Ar.wipeMetadata-checkMetadata :: LocalBuildInfo -> FilePath -> Assertion-checkMetadata lbi dir = withBinaryFile path ReadMode $ \ h -> do-    hFileSize h >>= checkArchive h-  where-    path = dir </> "libHS" ++ this ++ "-0"-           ++ (if ghc_7_10 then ("-" ++ packageKeyHash (pkgKey lbi)) else "")-           ++ ".a"--    ghc_7_10 = case compilerId (compiler lbi) of-      CompilerId GHC version | version >= Version [7, 10] [] -> True-      _                                                      -> False--    checkError msg = assertFailure' $-        "PackageTests.DeterministicAr.checkMetadata: " ++ msg ++-        " in " ++ path-    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 = 60--    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details-    checkArchive :: Handle -> Integer -> IO ()-    checkArchive h archiveSize = do-        global <- BS.hGet h (BS.length archLF)-        unless (global == archLF) $ checkError "Bad global header"-        checkHeader (toInteger $ BS.length archLF)--      where-        checkHeader :: Integer -> IO ()-        checkHeader offset = case compare offset archiveSize of-            EQ -> return ()-            GT -> checkError (atOffset "Archive truncated")-            LT -> do-                header <- BS.hGet h headerSize-                unless (BS.length header == headerSize) $-                    checkError (atOffset "Short header")-                let magic = BS.drop 58 header-                unless (magic == x60LF) . checkError . atOffset $-                    "Bad magic " ++ show magic ++ " in header"--                unless (metadata == BS.take 32 (BS.drop 16 header))-                    . checkError . atOffset $ "Metadata has changed"--                let size = BS.take 10 $ BS.drop 48 header-                objSize <- case reads (BS8.unpack size) of-                    [(n, s)] | all isSpace s -> return n-                    _ -> checkError (atOffset "Bad file size in header")--                let nextHeader = offset + toInteger headerSize +-                        -- Odd objects are padded with an extra '\x0a'-                        if odd objSize then objSize + 1 else objSize-                hSeek h AbsoluteSeek nextHeader-                checkHeader nextHeader--          where-            atOffset msg = msg ++ " at offset " ++ show offset
− tests/PackageTests/DeterministicAr/Lib.hs 
@@ -1,5 +0,0 @@-module Lib where--dummy :: IO ()-dummy = return ()-
− tests/PackageTests/DeterministicAr/my.cabal 
@@ -1,17 +0,0 @@-name: DeterministicAr-version: 0-license: BSD3-cabal-version: >= 1.9.1-author: Liyang HU-stability: stable-category: PackageTests-build-type: Simple--description:-    Ensure our GNU ar -D emulation (#1537) works as advertised: check that-    all metadata in the resulting .a archive match the default.--Library-    exposed-modules: Lib-    build-depends: base-
− tests/PackageTests/EmptyLib/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.EmptyLib.Check where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit---- See https://github.com/haskell/cabal/issues/1241-emptyLib :: FilePath -> Test-emptyLib ghcPath = TestCase $ do-   let spec = PackageSpec-          { directory = "PackageTests" </> "EmptyLib" </> "empty"-          , configOpts = []-          , distPref = Nothing-          }-   result <- cabal_build spec ghcPath-   assertBuildSucceeded result
− tests/PackageTests/EmptyLib/empty/empty.cabal 
@@ -1,6 +0,0 @@-name: emptyLib-Cabal-version: >= 1.2-version: 1.0-build-type: Simple--Library
− tests/PackageTests/Haddock/CPP.hs 
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}--module CPP where--#define HIDING  hiding-#define NEEDLES needles---- | For HIDING NEEDLES.-data Haystack = Haystack
− tests/PackageTests/Haddock/Check.hs 
@@ -1,42 +0,0 @@-module PackageTests.Haddock.Check (suite) where--import Control.Monad (unless, when)-import Data.List (isInfixOf)--import System.FilePath ((</>))-import System.Directory (doesDirectoryExist, removeDirectoryRecursive)-import Test.HUnit (Assertion, Test (TestCase), assertFailure)--import Distribution.Simple.Utils (withFileContents)-import PackageTests.PackageTester-    (PackageSpec(..), assertHaddockSucceeded, cabal_haddock)--this :: String-this = "Haddock"--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let dir = "PackageTests" </> this-        haddocksDir = dir </> "dist" </> "doc" </> "html" </> "Haddock"-        spec = PackageSpec-            { directory = dir-            , configOpts = []-            , distPref = Nothing-            }--    haddocksDirExists <- doesDirectoryExist haddocksDir-    when haddocksDirExists (removeDirectoryRecursive haddocksDir)-    hResult <- cabal_haddock spec [] ghcPath-    assertHaddockSucceeded hResult--    let docFiles = map (haddocksDir </>)-                       ["CPP.html", "Literate.html", "NoCPP.html", "Simple.html"]-    mapM_ (assertFindInFile "For hiding needles.") docFiles--assertFindInFile :: String -> FilePath -> Assertion-assertFindInFile needle path =-    withFileContents path-                     (\contents ->-                      unless (needle `isInfixOf` contents)-                             (assertFailure ("expected: " ++ needle ++ "\n" ++-                                             " in file: " ++ path)))
− tests/PackageTests/Haddock/Literate.lhs 
@@ -1,4 +0,0 @@-> module Literate where--> -- | For hiding needles.-> data Haystack = Haystack
− tests/PackageTests/Haddock/NoCPP.hs 
@@ -1,8 +0,0 @@-module NoCPP (Haystack) where---- | For hiding needles.-data Haystack = Haystack---- | Causes a build failure if the CPP language extension is enabled.-stringGap = "Foo\-\Bar"
− tests/PackageTests/Haddock/Simple.hs 
@@ -1,4 +0,0 @@-module Simple where---- | For hiding needles.-data Haystack = Haystack
− tests/PackageTests/Haddock/my.cabal 
@@ -1,16 +0,0 @@-name: Haddock-version: 0.1-license: BSD3-author: Iain Nicol-stability: stable-category: PackageTests-build-type: Simple-Cabal-version: >= 1.2--description:-    Check that Cabal successfully invokes Haddock.--Library-    exposed-modules: CPP, Literate, NoCPP, Simple-    other-extensions: CPP-    build-depends: base
− tests/PackageTests/OrderFlags/Check.hs 
@@ -1,24 +0,0 @@-module PackageTests.OrderFlags.Check where--import Test.HUnit-import PackageTests.PackageTester-import System.FilePath-import Control.Exception--#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "OrderFlags"-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    do-        assertEqual "cabal build should succeed - see test-log.txt" True (successful result)-      `catch` \exc -> do-        putStrLn $ "Cabal result was "++show result-        throwIO (exc :: SomeException)
− tests/PackageTests/OrderFlags/Foo.hs 
@@ -1,8 +0,0 @@-module Foo where--x :: IO Int-x = return 5--f :: IO Int-f = do x-       return 3
− tests/PackageTests/OrderFlags/my.cabal 
@@ -1,20 +0,0 @@-name: OrderFlags-version: 0.1-license: BSD3-author: Oleksandr Manzyuk-stability: stable-category: PackageTests-build-type: Simple-cabal-version: >=1.9.2--description:-    Check that Cabal correctly orders flags that are passed to GHC.--library-    exposed-modules: Foo-    build-depends: base--    ghc-options: -Wall -Werror--    if impl(ghc >= 6.12.1)-        ghc-options: -fno-warn-unused-do-bind
− tests/PackageTests/PackageTester.hs 
@@ -1,308 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}---- You can set the following VERBOSE environment variable to control--- the verbosity of the output generated by this module.-module PackageTests.PackageTester-    ( PackageSpec(..)-    , Success(..)-    , Result(..)--    -- * Running cabal commands-    , cabal_configure-    , cabal_build-    , cabal_haddock-    , cabal_test-    , cabal_bench-    , cabal_install-    , unregister-    , compileSetup-    , run--    -- * Test helpers-    , assertBuildSucceeded-    , assertBuildFailed-    , assertHaddockSucceeded-    , assertTestSucceeded-    , assertInstallSucceeded-    , assertOutputContains-    , assertOutputDoesNotContain-    ) where--import qualified Control.Exception.Extensible as E-import Control.Monad-import qualified Data.ByteString.Char8 as C-import Data.List-import Data.Maybe-import System.Directory (canonicalizePath, doesFileExist, getCurrentDirectory)-import System.Environment (getEnv)-import System.Exit (ExitCode(ExitSuccess))-import System.FilePath-import System.IO (hIsEOF, hGetChar, hClose)-import System.IO.Error (isDoesNotExistError)-import System.Process (runProcess, waitForProcess)-import Test.HUnit (Assertion, assertFailure)--import Distribution.Compat.CreatePipe (createPipe)-import Distribution.Simple.BuildPaths (exeExtension)-import Distribution.Simple.Program.Run (getEffectiveEnvironment)-import Distribution.Simple.Utils (printRawCommandAndArgsAndEnv)-import Distribution.ReadE (readEOrFail)-import Distribution.Verbosity (Verbosity, flagToVerbosity, normal)--data PackageSpec = PackageSpec-    { directory  :: FilePath-    , distPref :: Maybe FilePath-    , configOpts :: [String]-    }--data Success = Failure-             | ConfigureSuccess-             | BuildSuccess-             | HaddockSuccess-             | InstallSuccess-             | TestSuccess-             | BenchSuccess-             deriving (Eq, Show)--data Result = Result-    { successful :: Bool-    , success    :: Success-    , outputText :: String-    } deriving Show--nullResult :: Result-nullResult = Result True Failure ""----------------------------------------------------------------------------- * Running cabal commands--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 -> FilePath -> IO Result-cabal_configure spec ghcPath = do-    res <- doCabalConfigure spec ghcPath-    record spec res-    return res--doCabalConfigure :: PackageSpec -> FilePath -> IO Result-doCabalConfigure spec ghcPath = do-    cleanResult@(_, _, _) <- cabal spec [] ["clean"] ghcPath-    requireSuccess cleanResult-    res <- cabal spec []-           (["configure", "--user", "-w", ghcPath] ++ configOpts spec)-           ghcPath-    return $ recordRun res ConfigureSuccess nullResult--doCabalBuild :: PackageSpec -> FilePath -> IO Result-doCabalBuild spec ghcPath = do-    configResult <- doCabalConfigure spec ghcPath-    if successful configResult-        then do-            res <- cabal spec [] ["build", "-v"] ghcPath-            return $ recordRun res BuildSuccess configResult-        else-            return configResult--cabal_build :: PackageSpec -> FilePath -> IO Result-cabal_build spec ghcPath = do-    res <- doCabalBuild spec ghcPath-    record spec res-    return res--cabal_haddock :: PackageSpec -> [String] -> FilePath -> IO Result-cabal_haddock spec extraArgs ghcPath = do-    res <- doCabalHaddock spec extraArgs ghcPath-    record spec res-    return res--doCabalHaddock :: PackageSpec -> [String] -> FilePath -> IO Result-doCabalHaddock spec extraArgs ghcPath = do-    configResult <- doCabalConfigure spec ghcPath-    if successful configResult-        then do-            res <- cabal spec [] ("haddock" : extraArgs) ghcPath-            return $ recordRun res HaddockSuccess configResult-        else-            return configResult--unregister :: String -> FilePath -> IO ()-unregister libraryName ghcPkgPath = do-    res@(_, _, output) <- run Nothing ghcPkgPath [] ["unregister", "--user", libraryName]-    if "cannot find package" `isInfixOf` output-        then return ()-        else requireSuccess res---- | Install this library in the user area-cabal_install :: PackageSpec -> FilePath -> IO Result-cabal_install spec ghcPath = do-    buildResult <- doCabalBuild spec ghcPath-    res <- if successful buildResult-        then do-            res <- cabal spec [] ["install"] ghcPath-            return $ recordRun res InstallSuccess buildResult-        else-            return buildResult-    record spec res-    return res--cabal_test :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO Result-cabal_test spec envOverrides extraArgs ghcPath = do-    res <- cabal spec envOverrides ("test" : extraArgs) ghcPath-    let r = recordRun res TestSuccess nullResult-    record spec r-    return r--cabal_bench :: PackageSpec -> [String] -> FilePath -> IO Result-cabal_bench spec extraArgs ghcPath = do-    res <- cabal spec [] ("bench" : extraArgs) ghcPath-    let r = recordRun res BenchSuccess nullResult-    record spec r-    return r--compileSetup :: FilePath -> FilePath -> IO ()-compileSetup packageDir ghcPath = do-    wd <- getCurrentDirectory-    r <- run (Just $ packageDir) ghcPath []-         [ "--make"--- HPC causes trouble -- see #1012---       , "-fhpc"-         , "-package-conf " ++ wd </> "../dist/package.conf.inplace"-         , "Setup.hs"-         ]-    requireSuccess r---- | Returns the command that was issued, the return code, and the output text.-cabal :: PackageSpec -> [(String, Maybe String)] -> [String] -> FilePath -> IO (String, ExitCode, String)-cabal spec envOverrides cabalArgs_ ghcPath = do-    let cabalArgs = case distPref spec of-                       Nothing -> cabalArgs_-                       Just dist -> ("--builddir=" ++ dist) : cabalArgs_-    customSetup <- doesFileExist (directory spec </> "Setup.hs")-    if customSetup-        then do-            compileSetup (directory spec) ghcPath-            path <- canonicalizePath $ directory spec </> "Setup"-            run (Just $ directory spec) path envOverrides cabalArgs-        else do-            -- Use shared Setup executable (only for Simple build types).-            path <- canonicalizePath "Setup"-            run (Just $ directory spec) path envOverrides cabalArgs---- | Returns the command that was issued, the return code, and the output text-run :: Maybe FilePath -> String -> [(String, Maybe String)] -> [String] -> IO (String, ExitCode, String)-run cwd path envOverrides args = do-    verbosity <- getVerbosity-    -- path is relative to the current directory; canonicalizePath makes it-    -- absolute, so that runProcess will find it even when changing directory.-    path' <- do pathExists <- doesFileExist path-                canonicalizePath (if pathExists then path else path <.> exeExtension)-    menv <- getEffectiveEnvironment envOverrides--    printRawCommandAndArgsAndEnv verbosity path' args menv-    (readh, writeh) <- createPipe-    pid <- runProcess path' args cwd menv Nothing (Just writeh) (Just writeh)--    -- fork off a thread to start consuming the output-    out <- suckH [] readh-    hClose readh--    -- wait for the program to terminate-    exitcode <- waitForProcess pid-    let fullCmd = unwords (path' : args)-    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, exitcode, out)-  where-    suckH output h = do-        eof <- hIsEOF h-        if eof-            then return (reverse output)-            else do-                c <- hGetChar h-                suckH (c:output) h---requireSuccess :: (String, ExitCode, String) -> IO ()-requireSuccess (cmd, exitCode, output) =-    unless (exitCode == ExitSuccess) $-        assertFailure $ "Command " ++ cmd ++ " failed.\n" ++-        "output: " ++ output--record :: PackageSpec -> Result -> IO ()-record spec res = do-    C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res)----------------------------------------------------------------------------- * Test helpers--assertBuildSucceeded :: Result -> Assertion-assertBuildSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'setup build\' should succeed\n" ++-    "  output: " ++ outputText result--assertBuildFailed :: Result -> Assertion-assertBuildFailed result = when (successful result) $-    assertFailure $-    "expected: \'setup build\' should fail\n" ++-    "  output: " ++ outputText result--assertHaddockSucceeded :: Result -> Assertion-assertHaddockSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'setup haddock\' should succeed\n" ++-    "  output: " ++ outputText result--assertTestSucceeded :: Result -> Assertion-assertTestSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'setup test\' should succeed\n" ++-    "  output: " ++ outputText result--assertInstallSucceeded :: Result -> Assertion-assertInstallSucceeded result = unless (successful result) $-    assertFailure $-    "expected: \'setup install\' should succeed\n" ++-    "  output: " ++ outputText result--assertOutputContains :: String -> Result -> Assertion-assertOutputContains needle result =-    unless (needle `isInfixOf` (concatOutput output)) $-    assertFailure $-    " expected: " ++ needle ++ "\n" ++-    " in output: " ++ output ++ ""-  where output = outputText result--assertOutputDoesNotContain :: String -> Result -> Assertion-assertOutputDoesNotContain needle result =-    when (needle `isInfixOf` (concatOutput output)) $-    assertFailure $-    "unexpected: " ++ needle ++-    " in output: " ++ output-  where output = outputText result---- | Replace line breaks with spaces, correctly handling "\r\n".-concatOutput :: String -> String-concatOutput = unwords . lines . filter ((/=) '\r')----------------------------------------------------------------------------- Verbosity--lookupEnv :: String -> IO (Maybe String)-lookupEnv name =-    (fmap Just $ getEnv name)-    `E.catch` \ (e :: IOError) ->-        if isDoesNotExistError e-        then return Nothing-        else E.throw e---- TODO: Convert to a "-v" flag instead.-getVerbosity :: IO Verbosity-getVerbosity = do-    maybe normal (readEOrFail flagToVerbosity) `fmap` lookupEnv "VERBOSE"
− tests/PackageTests/PathsModule/Executable/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.PathsModule.Executable.Check (suite) where--import PackageTests.PackageTester-    (PackageSpec(..), assertBuildSucceeded, cabal_build)-import System.FilePath-import Test.HUnit--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "PathsModule" </> "Executable"-            , distPref = Nothing-            , configOpts = []-            }-    result <- cabal_build spec ghcPath-    assertBuildSucceeded result
− tests/PackageTests/PathsModule/Executable/Main.hs 
@@ -1,8 +0,0 @@-module Main where--import Paths_PathsModule (getBinDir)--main :: IO ()-main = do-    _ <- getBinDir-    return ()
− tests/PackageTests/PathsModule/Executable/my.cabal 
@@ -1,16 +0,0 @@-name: PathsModule-version: 0.1-license: BSD3-author: Johan Tibell-stability: stable-category: PackageTests-build-type: Simple-Cabal-version: >= 1.2--description:-    Check that the generated paths module compiles.--Executable TestPathsModule-    main-is: Main.hs-    other-modules: Paths_PathsModule-    build-depends: base
− tests/PackageTests/PathsModule/Library/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.PathsModule.Library.Check (suite) where--import PackageTests.PackageTester-    (PackageSpec(..), assertBuildSucceeded, cabal_build)-import System.FilePath-import Test.HUnit--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "PathsModule" </> "Library"-            , distPref = Nothing-            , configOpts = []-            }-    result <- cabal_build spec ghcPath-    assertBuildSucceeded result
− tests/PackageTests/PathsModule/Library/my.cabal 
@@ -1,15 +0,0 @@-name: PathsModule-version: 0.1-license: BSD3-author: Johan Tibell-stability: stable-category: PackageTests-build-type: Simple-Cabal-version: >= 1.2--description:-    Check that the generated paths module compiles.--Library-    exposed-modules: Paths_PathsModule-    build-depends: base
− tests/PackageTests/PreProcess/Check.hs 
@@ -1,16 +0,0 @@-module PackageTests.PreProcess.Check (suite) where--import PackageTests.PackageTester-    (PackageSpec(..), assertBuildSucceeded, cabal_build)-import System.FilePath-import Test.HUnit--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "PreProcess"-            , distPref = Nothing-            , configOpts = ["--enable-tests", "--enable-benchmarks"]-            }-    result <- cabal_build spec ghcPath-    assertBuildSucceeded result
− tests/PackageTests/PreProcess/Foo.hsc 
@@ -1,1 +0,0 @@-module Foo where
− tests/PackageTests/PreProcess/Main.hs 
@@ -1,6 +0,0 @@-module Main where--import Foo--main :: IO ()-main = return ()
− tests/PackageTests/PreProcess/my.cabal 
@@ -1,32 +0,0 @@-name: PreProcess-version: 0.1-license: BSD3-author: Johan Tibell-stability: stable-category: PackageTests-build-type: Simple-Cabal-version: >= 1.2--description:-    Check that preprocessors are run.--Library-    exposed-modules: Foo-    build-depends: base--Executable my-executable-    main-is: Main.hs-    other-modules: Foo-    build-depends: base--Test-Suite my-test-suite-    main-is: Main.hs-    type: exitcode-stdio-1.0-    other-modules: Foo-    build-depends: base--Benchmark my-benchmark-    main-is: Main.hs-    type: exitcode-stdio-1.0-    other-modules: Foo-    build-depends: base
− tests/PackageTests/ReexportedModules/Check.hs 
@@ -1,41 +0,0 @@-module PackageTests.ReexportedModules.Check where--import Data.Version-import PackageTests.PackageTester-import System.FilePath-import Test.HUnit-import Data.Maybe-import Data.List-import Control.Monad-import Data.Char-import Text.ParserCombinators.ReadP--orFail :: String -> [(a, String)] -> a-orFail err r = case find (all isSpace . snd) r of-    Nothing -> error err-    Just (i, _) -> i--find' :: (a -> Bool) -> [a] -> Maybe a-find' = find--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    -- ToDo: Turn this into a utility function-    (_, _, xs) <- run Nothing ghcPath [] ["--info"]-    let compat = (>= Version [7,9] [])-               . orFail "could not parse version"-               . readP_to_S parseVersion-               . snd-               . fromJust-               . find' ((=="Project version").fst)-               . orFail "could not parse ghc --info output"-               . reads-               $ xs-    when compat $ do-        let spec = PackageSpec-                { directory = "PackageTests" </> "ReexportedModules"-                , configOpts = []-                , distPref = Nothing-                }-        result <- cabal_build spec ghcPath-        assertBuildSucceeded result
− tests/PackageTests/ReexportedModules/ReexportedModules.cabal 
@@ -1,11 +0,0 @@-name:                ReexportedModules-version:             0.1.0.0-license-file:        LICENSE-author:              Edward Z. Yang-maintainer:          ezyang@cs.stanford.edu-build-type:          Simple-cabal-version:       >=1.21--library-  build-depends:       base, containers-  reexported-modules:  containers:Data.Map as DataMap
− tests/PackageTests/TemplateHaskell/Check.hs 
@@ -1,41 +0,0 @@-module PackageTests.TemplateHaskell.Check where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit--vanilla :: FilePath -> Test-vanilla ghcPath = TestCase $ do-  let spec = PackageSpec-          { directory = "PackageTests" </> "TemplateHaskell" </> "vanilla"-          , configOpts = []-          , distPref = Nothing-          }-  result <- cabal_build spec ghcPath-  assertBuildSucceeded result--profiling :: FilePath -> Test-profiling ghcPath = TestCase $ do-   let flags = ["--enable-library-profiling"---                ,"--disable-library-vanilla"-               ,"--enable-profiling"]-       spec = PackageSpec-          { directory = "PackageTests" </> "TemplateHaskell" </> "profiling"-          , configOpts = flags-          , distPref = Nothing-          }-   result <- cabal_build spec ghcPath-   assertBuildSucceeded result--dynamic :: FilePath -> Test-dynamic ghcPath = TestCase $ do-    let flags = ["--enable-shared"---                ,"--disable-library-vanilla"-                ,"--enable-executable-dynamic"]-        spec = PackageSpec-            { directory = "PackageTests" </> "TemplateHaskell" </> "dynamic"-            , configOpts = flags-            , distPref = Nothing-            }-    result <- cabal_build spec ghcPath-    assertBuildSucceeded result
− tests/PackageTests/TemplateHaskell/dynamic/Exe.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import TH--main = print $(splice)
− tests/PackageTests/TemplateHaskell/dynamic/Lib.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Lib where--import TH--val = $(splice)
− tests/PackageTests/TemplateHaskell/dynamic/TH.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module TH where--splice = [| () |]
− tests/PackageTests/TemplateHaskell/dynamic/my.cabal 
@@ -1,15 +0,0 @@-Name: templateHaskell-Version: 0.1-Build-Type: Simple-Cabal-Version: >= 1.2--Library-    Exposed-Modules: Lib-    Other-Modules: TH-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell--Executable main-    Main-is: Exe.hs-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell
− tests/PackageTests/TemplateHaskell/profiling/Exe.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import TH--main = print $(splice)
− tests/PackageTests/TemplateHaskell/profiling/Lib.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Lib where--import TH--val = $(splice)
− tests/PackageTests/TemplateHaskell/profiling/TH.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module TH where--splice = [| () |]
− tests/PackageTests/TemplateHaskell/profiling/my.cabal 
@@ -1,15 +0,0 @@-Name: templateHaskell-Version: 0.1-Build-Type: Simple-Cabal-Version: >= 1.2--Library-    Exposed-Modules: Lib-    Other-Modules: TH-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell--Executable main-    Main-is: Exe.hs-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell
− tests/PackageTests/TemplateHaskell/vanilla/Exe.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import TH--main = print $(splice)
− tests/PackageTests/TemplateHaskell/vanilla/Lib.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Lib where--import TH--val = $(splice)
− tests/PackageTests/TemplateHaskell/vanilla/TH.hs 
@@ -1,4 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module TH where--splice = [| () |]
− tests/PackageTests/TemplateHaskell/vanilla/my.cabal 
@@ -1,15 +0,0 @@-Name: templateHaskell-Version: 0.1-Build-Type: Simple-Cabal-Version: >= 1.2--Library-    Exposed-Modules: Lib-    Other-Modules: TH-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell--Executable main-    Main-is: Exe.hs-    Build-Depends: base, template-haskell-    Extensions: TemplateHaskell
− tests/PackageTests/TestOptions/Check.hs 
@@ -1,26 +0,0 @@-module PackageTests.TestOptions.Check where--import PackageTests.PackageTester-import System.FilePath-import Test.HUnit--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let spec = PackageSpec-            { directory = "PackageTests" </> "TestOptions"-            , configOpts = ["--enable-tests"]-            , distPref = Nothing-            }-    _ <- cabal_build spec ghcPath-    result <- cabal_test spec [] ["--test-options=1 2 3"] ghcPath-    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"-                                  ]-               ghcPath-    let message' = "\"cabal test\" did not pass the correct options to the "-                   ++ "test executable with \"--test-option\""-    assertEqual message' True $ successful result'
− tests/PackageTests/TestOptions/TestOptions.cabal 
@@ -1,20 +0,0 @@-name: TestOptions-version: 0.1-license: BSD3-author: Thomas Tuegel-stability: stable-category: PackageTests-build-type: Simple-cabal-version: >= 1.9.2--description:-    Check that Cabal passes the correct test options to test suites.--executable dummy-    main-is: test-TestOptions.hs-    build-depends: base--test-suite test-TestOptions-    main-is: test-TestOptions.hs-    type: exitcode-stdio-1.0-    build-depends: base
− tests/PackageTests/TestOptions/test-TestOptions.hs 
@@ -1,11 +0,0 @@-module Main where--import System.Environment ( getArgs )-import System.Exit ( exitFailure, exitSuccess )--main :: IO ()-main = do-    args <- getArgs-    if args == ["1", "2", "3"]-        then exitSuccess-        else putStrLn ("Got: " ++ show args) >> exitFailure
− tests/PackageTests/TestStanza/Check.hs 
@@ -1,53 +0,0 @@-module PackageTests.TestStanza.Check where--import Test.HUnit-import System.FilePath-import qualified  Data.Map as Map-import PackageTests.PackageTester-import Distribution.Version-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.PackageDescription.Configuration-    (finalizePackageDescription)-import Distribution.Package (PackageName(..), Dependency(..))-import Distribution.PackageDescription-    ( PackageDescription(..), BuildInfo(..), TestSuite(..)-    , TestSuiteInterface(..), emptyBuildInfo, emptyTestSuite-    , defaultRenaming)-import Distribution.Verbosity (silent)-import Distribution.System (buildPlatform)-import Distribution.Compiler-    ( CompilerId(..), CompilerFlavor(..), unknownCompilerInfo, AbiTag(..) )-import Distribution.Text--suite :: FilePath -> Test-suite ghcPath = TestCase $ do-    let dir = "PackageTests" </> "TestStanza"-        pdFile = dir </> "my" <.> "cabal"-        spec = PackageSpec-            { directory = dir-            , configOpts = []-            , distPref = Nothing-            }-    result <- cabal_configure spec ghcPath-    assertOutputDoesNotContain "unknown section type" result-    genPD <- readPackageDescription silent pdFile-    let compiler = unknownCompilerInfo (CompilerId GHC $ Version [6, 12, 2] []) NoAbiTag-        anticipatedTestSuite = emptyTestSuite-            { testName = "dummy"-            , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"-            , testBuildInfo = emptyBuildInfo-                    { targetBuildDepends =-                            [ Dependency (PackageName "base") anyVersion ]-                    , targetBuildRenaming =-                            Map.singleton (PackageName "base") defaultRenaming-                    , 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/TestStanza/my.cabal 
@@ -1,19 +0,0 @@-name: TestStanza-version: 0.1-license: BSD3-author: Thomas Tuegel-stability: stable-category: PackageTests-build-type: Simple--description:-    Check that Cabal recognizes the Test stanza defined below.--Library-    exposed-modules: MyLibrary-    build-depends: base--test-suite dummy-    main-is: dummy.hs-    type: exitcode-stdio-1.0-    build-depends: base
− tests/PackageTests/TestSuiteExeV10/Check.hs 
@@ -1,147 +0,0 @@-module PackageTests.TestSuiteExeV10.Check (checks) where--import qualified Control.Exception as E (IOException, catch)-import Control.Monad (when)-import Data.Maybe (catMaybes)-import System.Directory ( doesFileExist )-import System.FilePath-import qualified Test.Framework as TF-import Test.Framework (testGroup)-import Test.Framework.Providers.HUnit (hUnitTestToTests)-import Test.HUnit hiding ( path )--import Distribution.Compiler (CompilerFlavor(..), CompilerId(..))-import Distribution.PackageDescription (package)-import Distribution.Simple.Compiler (compilerId)-import Distribution.Simple.Configure (getPersistBuildConfig)-import Distribution.Simple.LocalBuildInfo (compiler, localPkgDescr, pkgKey)-import Distribution.Simple.Hpc-import Distribution.Simple.Program.Builtin (hpcProgram)-import Distribution.Simple.Program.Db-    ( emptyProgramDb, configureProgram, requireProgramVersion )-import Distribution.Text (display)-import qualified Distribution.Verbosity as Verbosity-import Distribution.Version (Version(..), orLaterVersion)--import PackageTests.PackageTester--checks :: FilePath -> [TF.Test]-checks ghcPath =-    [ hunit "Test" $ checkTest ghcPath ]-    ++ hpcTestMatrix ghcPath ++-    [ hunit "TestNoHpc/NoTix" $ checkTestNoHpcNoTix ghcPath-    , hunit "TestNoHpc/NoMarkup" $ checkTestNoHpcNoMarkup ghcPath-    ]--hpcTestMatrix :: FilePath -> [TF.Test]-hpcTestMatrix ghcPath = do-    libProf <- [True, False]-    exeProf <- [True, False]-    exeDyn <- [True, False]-    shared <- [True, False]-    let name = concat-            [ "WithHpc-"-            , if libProf then "LibProf" else ""-            , if exeProf then "ExeProf" else ""-            , if exeDyn then "ExeDyn" else ""-            , if shared then "Shared" else ""-            ]-        enable cond flag-          | cond = Just $ "--enable-" ++ flag-          | otherwise = Nothing-        opts = catMaybes-            [ enable libProf "library-profiling"-            , enable exeProf "profiling"-            , enable exeDyn "executable-dynamic"-            , enable shared "shared"-            ]-    return $ hunit name $ checkTestWithHpc ghcPath name opts--dir :: FilePath-dir = "PackageTests" </> "TestSuiteExeV10"--checkTest :: FilePath -> Test-checkTest ghcPath = TestCase $ buildAndTest ghcPath "Default" [] []--shouldExist :: FilePath -> Assertion-shouldExist path = doesFileExist path >>= assertBool (path ++ " should exist")--shouldNotExist :: FilePath -> Assertion-shouldNotExist path =-    doesFileExist path >>= assertBool (path ++ " should exist") . not---- | Ensure that both .tix file and markup are generated if coverage is enabled.-checkTestWithHpc :: FilePath -> String -> [String] -> Test-checkTestWithHpc ghcPath name extraOpts = TestCase $ do-    isCorrectVersion <- correctHpcVersion-    when isCorrectVersion $ do-        let distPref' = dir </> "dist-" ++ name-        buildAndTest ghcPath name [] ("--enable-coverage" : extraOpts)-        lbi <- getPersistBuildConfig distPref'-        let way = guessWay lbi-            CompilerId comp version = compilerId (compiler lbi)-            subdir-              | comp == GHC && version >= Version [7, 10] [] =-                  display (pkgKey lbi)-              | otherwise = display (package $ localPkgDescr lbi)-        mapM_ shouldExist-            [ mixDir distPref' way "my-0.1" </> subdir </> "Foo.mix"-            , mixDir distPref' way "test-Foo" </> "Main.mix"-            , tixFilePath distPref' way "test-Foo"-            , htmlDir distPref' way "test-Foo" </> "hpc_index.html"-            ]---- | Ensures that even if -fhpc is manually provided no .tix file is output.-checkTestNoHpcNoTix :: FilePath -> Test-checkTestNoHpcNoTix ghcPath = TestCase $ do-    buildAndTest ghcPath "NoHpcNoTix" []-      [ "--ghc-option=-fhpc"-      , "--ghc-option=-hpcdir"-      , "--ghc-option=dist-NoHpcNoTix/hpc/vanilla" ]-    lbi <- getPersistBuildConfig (dir </> "dist-NoHpcNoTix")-    let way = guessWay lbi-    shouldNotExist $ tixFilePath (dir </> "dist-NoHpcNoTix") way "test-Foo"---- | Ensures that even if a .tix file happens to be left around--- markup isn't generated.-checkTestNoHpcNoMarkup :: FilePath -> Test-checkTestNoHpcNoMarkup ghcPath = TestCase $ do-    let tixFile = tixFilePath "dist-NoHpcNoMarkup" Vanilla "test-Foo"-    buildAndTest ghcPath "NoHpcNoMarkup"-      [("HPCTIXFILE", Just tixFile)]-      [ "--ghc-option=-fhpc"-      , "--ghc-option=-hpcdir"-      , "--ghc-option=dist-NoHpcNoMarkup/hpc/vanilla" ]-    shouldNotExist $ htmlDir (dir </> "dist-NoHpcNoMarkup") Vanilla "test-Foo" </> "hpc_index.html"---- | Build and test a package and ensure that both were successful.------ The flag "--enable-tests" is provided in addition to the given flags.-buildAndTest :: FilePath -> String -> [(String, Maybe String)] -> [String] -> IO ()-buildAndTest ghcPath name envOverrides flags = do-    let spec = PackageSpec-            { directory = dir-            , distPref = Just $ "dist-" ++ name-            , configOpts = "--enable-tests" : flags-            }-    buildResult <- cabal_build spec ghcPath-    assertBuildSucceeded buildResult-    testResult <- cabal_test spec envOverrides [] ghcPath-    assertTestSucceeded testResult--hunit :: TF.TestName -> Test -> TF.Test-hunit name = testGroup name . hUnitTestToTests---- | Checks for a suitable HPC version for testing.-correctHpcVersion :: IO Bool-correctHpcVersion = do-    let programDb' = emptyProgramDb-    let verbosity = Verbosity.normal-    let verRange  = orLaterVersion (Version [0,7] [])-    programDb <- configureProgram verbosity hpcProgram programDb'-    (requireProgramVersion verbosity hpcProgram verRange programDb-     >> return True) `catchIO` (\_ -> return False)-  where-    -- Distribution.Compat.Exception is hidden.-    catchIO :: IO a -> (E.IOException -> IO a) -> IO a-    catchIO = E.catch
− tests/PackageTests/TestSuiteExeV10/Foo.hs 
@@ -1,4 +0,0 @@-module Foo where--fooTest :: [String] -> Bool-fooTest _ = True
− tests/PackageTests/TestSuiteExeV10/my.cabal 
@@ -1,15 +0,0 @@-name:           my-version:        0.1-license:        BSD3-cabal-version:  >= 1.9.2-build-type:     Simple--library-    exposed-modules:    Foo-    build-depends:      base--test-suite test-Foo-    type:   exitcode-stdio-1.0-    hs-source-dirs: tests-    main-is:    test-Foo.hs-    build-depends: base, my
− tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs 
@@ -1,8 +0,0 @@-module Main where--import Foo-import System.Exit--main :: IO ()-main | fooTest [] = exitSuccess-     | otherwise = exitFailure
− tests/README.md 
@@ -1,34 +0,0 @@-Writing package tests-=====================--The tests under the [PackageTests] directory define and build packages-that exercise various components of Cabal. Each test case is an [HUnit]-test. The entry point for the test suite, where all the test cases are-listed, is [PackageTests.hs]. There are utilities for calling the stages-of Cabal's build process in [PackageTests/PackageTester.hs]; have a look-at an existing test case to see how they are used.--It is important that package tests use the in-place version of Cabal-rather than the system version. Several long-standing bugs in the test-suite were caused by testing the system (rather than the newly compiled)-version of Cabal. There are two places where the system Cabal can-accidentally be invoked:--1. Compiling `Setup.hs`. `runghc` needs to be told about the in-place-   package database. This issue should be solved for all future package-   tests; see `compileSetup` in [PackageTests/PackageTester.hs].--2. Compiling a package which depends on Cabal. In particular, packages-   with the [detailed]-type test suites depend on the Cabal library-   directly, so it is important that they are configured to use the-   in-place package database. The test suite already creates a stub-   `PackageSpec` for this case; see-   [PackageTests/BuildTestSuiteDetailedV09/Check.hs] to see how it is-   used.--[PackageTests]: PackageTests-[HUnit]: http://hackage.haskell.org/package/HUnit-[PackageTests.hs]: PackageTests.hs-[PackageTests/PackageTester.hs]: PackageTests/PackageTester.hs-[detailed]: ../Distribution/TestSuite.hs-[PackageTests/BuildTestSuiteDetailedV09/Check.hs]: PackageTests/BuildTestSuiteDetailedV09/Check.hs
− tests/Setup.hs 
@@ -1,3 +0,0 @@-import Distribution.Simple-main = defaultMain-
− tests/UnitTests.hs 
@@ -1,27 +0,0 @@-module Main-    ( main-    ) where--import System.IO (BufferMode(NoBuffering), hSetBuffering, stdout)-import Test.Framework--import qualified UnitTests.Distribution.Compat.CreatePipe-import qualified UnitTests.Distribution.Compat.ReadP-import qualified UnitTests.Distribution.Utils.NubList--tests :: [Test]-tests =-    [ testGroup "Distribution.Compat.ReadP"-        UnitTests.Distribution.Compat.ReadP.tests-    , testGroup "Distribution.Compat.CreatePipe"-        UnitTests.Distribution.Compat.CreatePipe.tests-    , testGroup "Distribution.Utils.NubList"-        UnitTests.Distribution.Utils.NubList.tests-    ]--main :: IO ()-main = do-    -- WORKAROUND: disable buffering on stdout to get streaming test logs-    -- test providers _should_ do this themselves-    hSetBuffering stdout NoBuffering-    defaultMain tests
− tests/UnitTests/Distribution/Compat/CreatePipe.hs 
@@ -1,20 +0,0 @@-module UnitTests.Distribution.Compat.CreatePipe (tests) where--import Distribution.Compat.CreatePipe-import System.IO (hClose, hGetContents, hPutStr, hSetEncoding, localeEncoding)-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--tests :: [Test]-tests = [testCase "Locale Encoding" case_Locale_Encoding]--case_Locale_Encoding :: Assertion-case_Locale_Encoding = assert $ do-    let str = "\0252"-    (r, w) <- createPipe-    hSetEncoding w localeEncoding-    out <- hGetContents r-    hPutStr w str-    hClose w-    return $! out == str
− tests/UnitTests/Distribution/Compat/ReadP.hs 
@@ -1,153 +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 code was originally in Distribution.Compat.ReadP. Please see that file--- for provenance. The tests have been integrated into the test framework.--- Some properties cannot be tested, as they hold over arbitrary ReadP values,--- and we don't have a good Arbitrary instance (nor Show instance) for ReadP.----module UnitTests.Distribution.Compat.ReadP-    ( tests-    -- * Properties-    -- $properties-    ) where--import Data.List-import Distribution.Compat.ReadP-import Test.Framework-import Test.Framework.Providers.QuickCheck2--tests :: [Test]-tests =-    [ testProperty "Get Nil" prop_Get_Nil-    , testProperty "Get Cons" prop_Get_Cons-    , testProperty "Look" prop_Look-    , testProperty "Fail" prop_Fail-    , testProperty "Return" prop_Return-    --, testProperty "Bind" prop_Bind-    --, testProperty "Plus" prop_Plus-    --, testProperty "LeftPlus" prop_LeftPlus-    --, testProperty "Gather" prop_Gather-    , testProperty "String Yes" prop_String_Yes-    , testProperty "String Maybe" prop_String_Maybe-    , testProperty "Munch" (prop_Munch evenChar)-    , testProperty "Munch1" (prop_Munch1 evenChar)-    --, testProperty "Choice" prop_Choice-    --, testProperty "ReadS" prop_ReadS-    ]---- ------------------------------------------------------------------------------ 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 :: Bool-prop_Get_Nil =-  readP_to_S get [] =~ []--prop_Get_Cons :: Char -> [Char] -> Bool-prop_Get_Cons c s =-  readP_to_S get (c:s) =~ [(c,s)]--prop_Look :: String -> Bool-prop_Look s =-  readP_to_S look s =~ [(s,s)]--prop_Fail :: String -> Bool-prop_Fail s =-  readP_to_S pfail s =~. []--prop_Return :: Int -> String -> Bool-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 :: ReadP Int Int -> ReadP Int Int -> String -> Bool-prop_Plus p q s =-  readP_to_S (p +++ q) s =~.-    (readP_to_S p s ++ readP_to_S q s)--prop_LeftPlus :: ReadP Int Int -> ReadP Int Int -> String -> Bool-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 :: String -> [Char] -> Bool-prop_String_Yes this s =-  readP_to_S (string this) (this ++ s) =~-    [(this,s)]--prop_String_Maybe :: String -> String -> Bool-prop_String_Maybe this s =-  readP_to_S (string this) s =~-    [(this, drop (length this) s) | this `isPrefixOf` s]--prop_Munch :: (Char -> Bool) -> String -> Bool-prop_Munch p s =-  readP_to_S (munch p) s =~-    [(takeWhile p s, dropWhile p s)]--prop_Munch1 :: (Char -> Bool) -> String -> Bool-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 :: [ReadP Int Int] -> String -> Bool-prop_Choice ps s =-  readP_to_S (choice ps) s =~.-    readP_to_S (foldr (+++) pfail ps) s--prop_ReadS :: ReadS Int -> String -> Bool-prop_ReadS r s =-  readP_to_S (readS_to_P r) s =~. r s--}--evenChar :: Char -> Bool-evenChar = even . fromEnum
− tests/UnitTests/Distribution/Utils/NubList.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}-module UnitTests.Distribution.Utils.NubList-    ( tests-    ) where--#if __GLASGOW_HASKELL__ < 710-import Data.Monoid-#endif-import Distribution.Utils.NubList-import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2-import Test.HUnit (Assertion, assertBool)--tests :: [Test]-tests =-    [ testCase "Numlist retains ordering" testOrdering-    , testCase "Numlist removes duplicates" testDeDupe-    , testProperty "Monoid Numlist Identity" prop_Identity-    , testProperty "Monoid Numlist Associativity" prop_Associativity-    ]--someIntList :: [Int]--- This list must not have duplicate entries.-someIntList = [ 1, 3, 4, 2, 0, 7, 6, 5, 9, -1 ]--testOrdering :: Assertion-testOrdering =-    assertBool "Maintains element ordering:" $-        fromNubList (toNubList someIntList) == someIntList--testDeDupe :: Assertion-testDeDupe =-    assertBool "De-duplicates a list:" $-        fromNubList (toNubList (someIntList ++ someIntList)) == someIntList---- ------------------------------------------------------------------------------ QuickCheck properties for NubList--prop_Identity :: [Int] -> Bool-prop_Identity xs =-    mempty `mappend` toNubList xs == toNubList xs `mappend` mempty--prop_Associativity :: [Int] -> [Int] -> [Int] -> Bool-prop_Associativity xs ys zs =-    (toNubList xs `mappend` toNubList ys) `mappend` toNubList zs-            == toNubList xs `mappend` (toNubList ys `mappend` toNubList zs)
− tests/hackage/check.sh 
@@ -1,25 +0,0 @@-#!/bin/sh--base_version=1.4.0.2-test_version=1.5.6--for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do--  pkgname=$(basename ${setup})-  -  if test $(wc -w < ${setup}) -gt 21; then-    if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then--      if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then-        echo "OK ${setup}"-      else-        echo "FAIL ${setup} does not compile with Cabal-${test_version}"     -      fi-    else-      echo "OK ${setup} (does not compile with Cabal-${base_version})" -    fi-  else-    echo "trivial ${setup}"-  fi--done
− tests/hackage/download.sh 
@@ -1,19 +0,0 @@-#!/bin/sh--if test ! -f archive/archive.tar; then--  wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar-  mkdir -p archive-  mv archive.tar archive/-  tar -C archive -xf archive/archive.tar    --fi--if test ! -f archive/00-index.tar.gz; then--  wget http://hackage.haskell.org/packages/archive/00-index.tar.gz-  mkdir -p archive-  mv 00-index.tar.gz archive/-  tar -C archive -xzf archive/00-index.tar.gz--fi
− tests/hackage/unpack.sh 
@@ -1,16 +0,0 @@-#!/bin/sh--for tarball in archive/*/*/*.tar.gz; do--  pkgdir=$(dirname ${tarball})-  pkgname=$(basename ${tarball} .tar.gz)--  if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then-    tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs-  elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then-    tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs-  else-    echo "${pkgname} has no Setup.hs or .lhs at all!!?!"-  fi--done
− tests/misc/ghc-supported-languages.hs 
@@ -1,97 +0,0 @@--- | A test program to check that ghc has got all of its extensions registered----module Main where--import Language.Haskell.Extension-import Distribution.Text-import Distribution.Simple.Utils-import Distribution.Verbosity--import Data.List ((\\))-import Data.Maybe-import Control.Applicative-import Control.Monad-import System.Environment-import System.Exit---- | A list of GHC extensions that are deliberately not registered,--- e.g. due to being experimental and not ready for public consumption----exceptions = map readExtension []--checkProblems :: [Extension] -> [String]-checkProblems implemented =--  let unregistered  =-        [ ext | ext <- implemented          -- extensions that ghc knows about -              , not (registered ext)        -- but that are not registered-              , ext `notElem` exceptions ]  -- except for the exceptions--      -- check if someone has forgotten to update the exceptions list...--      -- exceptions that are not implemented-      badExceptions  = exceptions \\ implemented-      -      -- exceptions that are now registered-      badExceptions' = filter registered exceptions-      -   in catMaybes-      [ check unregistered $ unlines-          [ "The following extensions are known to GHC but are not in the "-          , "extension registry in Language.Haskell.Extension."-          , "  " ++ intercalate "\n  " (map display unregistered)-          , "If these extensions are ready for public consumption then they "-          , "should be registered. If they are still experimental and you "-          , "think they are not ready to be registered then please add them "-          , "to the exceptions list in this test program along with an "-          , "explanation."-          ]-      , check badExceptions $ unlines-          [ "Error in the extension exception list. The following extensions"-          , "are listed as exceptions but are not even implemented by GHC:"-          , "  " ++ intercalate "\n  " (map display badExceptions)-          , "Please fix this test program by correcting the list of"-          , "exceptions."-          ]-      , check badExceptions' $ unlines-          [ "Error in the extension exception list. The following extensions"-          , "are listed as exceptions to registration but they are in fact"-          , "now registered in Language.Haskell.Extension:"-          , "  " ++ intercalate "\n  " (map display badExceptions')-          , "Please fix this test program by correcting the list of"-          , "exceptions."-          ]-      ]-  where-   registered (UnknownExtension _) = False-   registered _                    = True--   check [] _ = Nothing  -   check _  i = Just i---main = topHandler $ do-  [ghcPath] <- getArgs-  exts      <- getExtensions ghcPath-  let problems = checkProblems exts-  putStrLn (intercalate "\n" problems)-  if null problems-    then exitSuccess-    else exitFailure--getExtensions :: FilePath -> IO [Extension]-getExtensions ghcPath =-        map readExtension . lines-    <$> rawSystemStdout normal ghcPath ["--supported-languages"]--readExtension :: String -> Extension-readExtension str = handleNoParse $ do-    -- GHC defines extensions in a positive way, Cabal defines them-    -- relative to H98 so we try parsing ("No" ++ extName) first-    ext <- simpleParse ("No" ++ str)-    case ext of-      UnknownExtension _ -> simpleParse str-      _                  -> return ext-  where-    handleNoParse :: Maybe Extension -> Extension-    handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)