diff --git a/Cabal.cabal b/Cabal.cabal --- a/Cabal.cabal +++ b/Cabal.cabal @@ -1,8 +1,8 @@ -cabal-version: >=1.10 +cabal-version: 3.6 name: Cabal -version: 3.6.3.0 -copyright: 2003-2021, Cabal Development Team (see AUTHORS file) -license: BSD3 +version: 3.16.1.0 +copyright: 2003-2025, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team maintainer: cabal-devel@haskell.org @@ -21,7 +21,7 @@ -- If we use a new Cabal feature, this needs to be changed to Custom so -- we can bootstrap. -extra-source-files: +extra-doc-files: README.md ChangeLog.md source-repository head @@ -29,56 +29,55 @@ location: https://github.com/haskell/cabal/ subdir: Cabal -flag bundled-binary-generic +flag git-rev + description: include Git revision hash in version default: False + manual: True library default-language: Haskell2010 hs-source-dirs: src build-depends: - array >= 0.4.0.1 && < 0.6, - base >= 4.6 && < 5, - bytestring >= 0.10.0.0 && < 0.12, - containers >= 0.5.0.0 && < 0.7, - deepseq >= 1.3.0.1 && < 1.5, - directory >= 1.2 && < 1.4, - filepath >= 1.3.0.1 && < 1.5, - pretty >= 1.1.1 && < 1.2, - process >= 1.1.0.2 && < 1.7, - time >= 1.4.0.1 && < 1.13 - - if flag(bundled-binary-generic) - build-depends: binary >= 0.5.1.1 && < 0.7 - else - build-depends: binary >= 0.7 && < 0.9 + , Cabal-syntax ^>= 3.16.1.0 + , array >= 0.4.0.1 && < 0.6 + , base >= 4.13 && < 5 + , bytestring >= 0.10.0.0 && < 0.13 + , containers >= 0.5.0.0 && < 0.9 + , deepseq >= 1.3.0.1 && < 1.7 + , directory >= 1.2 && < 1.4 + , filepath >= 1.3.0.1 && < 1.6 + , pretty >= 1.1.1 && < 1.2 + , process >= 1.2.1.0 && < 1.7 + , time >= 1.4.0.1 && < 1.16 if os(windows) - build-depends: Win32 >= 2.3.0.0 && < 2.13 + build-depends: + , Win32 >= 2.3.0.0 && < 2.15 else - build-depends: unix >= 2.6.0.0 && < 2.8 - - ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - if impl(ghc >= 8.0) - ghc-options: -Wcompat -Wnoncanonical-monad-instances + build-depends: + , unix >= 2.8.6.0 && < 2.9 - if impl(ghc <8.8) - ghc-options: -Wnoncanonical-monadfail-instances + if flag(git-rev) + build-depends: + , githash ^>= 0.1.7.0 + cpp-options: -DGIT_REV - if !impl(ghc >= 8.0) - -- at least one of lib:Cabal's dependency (i.e. `parsec`) - -- already depends on `fail` and `semigroups` transitively - build-depends: fail == 4.9.*, semigroups >= 0.18.3 && < 0.21 + ghc-options: + -Wall + -fno-ignore-asserts + -Wtabs + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wno-unticked-promoted-constructors - if !impl(ghc >= 7.10) - build-depends: void >= 0.7.3 && < 0.8 + if impl(ghc >= 8.0) + ghc-options: -Wcompat -Wnoncanonical-monad-instances - if !impl(ghc >= 7.8) - -- semigroups depends on tagged. - build-depends: tagged >=0.8.6 && <0.9 + if impl(ghc >= 8.0) && impl(ghc < 8.8) + ghc-options: -Wnoncanonical-monadfail-instances exposed-modules: - Distribution.Backpack Distribution.Backpack.Configure Distribution.Backpack.ComponentsGraph Distribution.Backpack.ConfiguredComponent @@ -88,71 +87,54 @@ Distribution.Backpack.ModSubst Distribution.Backpack.ModuleShape Distribution.Backpack.PreModuleShape - Distribution.CabalSpecVersion Distribution.Utils.IOData - Distribution.Utils.Path Distribution.Utils.LogProgress Distribution.Utils.MapAccum - Distribution.Utils.MD5 - Distribution.Utils.Structured Distribution.Compat.CreatePipe Distribution.Compat.Directory Distribution.Compat.Environment - Distribution.Compat.Exception Distribution.Compat.FilePath - Distribution.Compat.Graph Distribution.Compat.Internal.TempFile - Distribution.Compat.Newtype - Distribution.Compat.NonEmptySet Distribution.Compat.ResponseFile Distribution.Compat.Prelude.Internal Distribution.Compat.Process - Distribution.Compat.Semigroup Distribution.Compat.Stack Distribution.Compat.Time - Distribution.Compat.Typeable - Distribution.Compat.DList - Distribution.Compiler - Distribution.InstalledPackageInfo - Distribution.Types.AbiDependency - Distribution.Types.ExposedModule - Distribution.Types.InstalledPackageInfo - Distribution.Types.InstalledPackageInfo.FieldGrammar - Distribution.License Distribution.Make - Distribution.ModuleName - Distribution.Package - Distribution.PackageDescription Distribution.PackageDescription.Check - Distribution.PackageDescription.Configuration - Distribution.PackageDescription.PrettyPrint - Distribution.PackageDescription.Utils Distribution.ReadE Distribution.Simple Distribution.Simple.Bench Distribution.Simple.Build + Distribution.Simple.Build.Inputs Distribution.Simple.Build.Macros + Distribution.Simple.Build.PackageInfoModule Distribution.Simple.Build.PathsModule Distribution.Simple.BuildPaths Distribution.Simple.BuildTarget Distribution.Simple.BuildToolDepends + Distribution.Simple.BuildWay Distribution.Simple.CCompiler Distribution.Simple.Command Distribution.Simple.Compiler Distribution.Simple.Configure + Distribution.Simple.Errors + Distribution.Simple.FileMonitor.Types Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHCJS Distribution.Simple.Haddock Distribution.Simple.Glob - Distribution.Simple.HaskellSuite + Distribution.Simple.Glob.Internal Distribution.Simple.Hpc Distribution.Simple.Install Distribution.Simple.InstallDirs Distribution.Simple.InstallDirs.Internal Distribution.Simple.LocalBuildInfo + Distribution.Simple.PackageDescription Distribution.Simple.PackageIndex Distribution.Simple.PreProcess + Distribution.Simple.PreProcess.Types Distribution.Simple.PreProcess.Unlit Distribution.Simple.Program Distribution.Simple.Program.Ar @@ -179,140 +161,178 @@ Distribution.Simple.Test.Log Distribution.Simple.UHC Distribution.Simple.UserHooks + Distribution.Simple.SetupHooks.Errors + Distribution.Simple.SetupHooks.Internal + Distribution.Simple.SetupHooks.Rule Distribution.Simple.Utils - Distribution.SPDX - Distribution.SPDX.License - Distribution.SPDX.LicenseId - Distribution.SPDX.LicenseExceptionId - Distribution.SPDX.LicenseExpression - Distribution.SPDX.LicenseListVersion - Distribution.SPDX.LicenseReference - Distribution.System Distribution.TestSuite - Distribution.Text - Distribution.Pretty - Distribution.Types.AbiHash Distribution.Types.AnnotatedId - Distribution.Types.Benchmark - Distribution.Types.BenchmarkInterface - Distribution.Types.BenchmarkType - Distribution.Types.BuildInfo - Distribution.Types.BuildType Distribution.Types.ComponentInclude - Distribution.Types.ConfVar - Distribution.Types.Dependency - Distribution.Types.ExeDependency - Distribution.Types.LegacyExeDependency - Distribution.Types.PkgconfigDependency - Distribution.Types.DependencyMap - Distribution.Types.ComponentId - Distribution.Types.MungedPackageId - Distribution.Types.PackageId - Distribution.Types.UnitId - Distribution.Types.Executable - Distribution.Types.ExecutableScope - Distribution.Types.Library - Distribution.Types.LibraryVisibility - Distribution.Types.Flag - Distribution.Types.ForeignLib - Distribution.Types.ForeignLibType - Distribution.Types.ForeignLibOption - Distribution.Types.Module - Distribution.Types.ModuleReexport - Distribution.Types.ModuleRenaming - Distribution.Types.ComponentName - Distribution.Types.LibraryName - Distribution.Types.MungedPackageName - Distribution.Types.PackageName + Distribution.Types.DumpBuildInfo Distribution.Types.PackageName.Magic - Distribution.Types.PkgconfigName - Distribution.Types.PkgconfigVersion - Distribution.Types.PkgconfigVersionRange - Distribution.Types.UnqualComponentName - Distribution.Types.IncludeRenaming - Distribution.Types.Mixin - Distribution.Types.SetupBuildInfo - Distribution.Types.TestSuite - Distribution.Types.TestSuiteInterface - Distribution.Types.TestType - Distribution.Types.GenericPackageDescription - Distribution.Types.Condition - Distribution.Types.CondTree - Distribution.Types.HookedBuildInfo - Distribution.Types.PackageDescription - Distribution.Types.SourceRepo - Distribution.Types.Component Distribution.Types.ComponentLocalBuildInfo + Distribution.Types.LocalBuildConfig Distribution.Types.LocalBuildInfo - Distribution.Types.ComponentRequestedSpec Distribution.Types.TargetInfo - Distribution.Types.Version - Distribution.Types.VersionRange - Distribution.Types.VersionRange.Internal - Distribution.Types.VersionInterval - Distribution.Types.VersionInterval.Legacy Distribution.Types.GivenComponent - Distribution.Types.PackageVersionConstraint - Distribution.Utils.Generic + Distribution.Types.ParStrat + Distribution.Utils.Json Distribution.Utils.NubList - Distribution.Utils.ShortText Distribution.Utils.Progress Distribution.Verbosity Distribution.Verbosity.Internal - Distribution.Version + + -- We reexport all of Cabal-syntax to aid in compatibility for downstream + -- users. In the future we may opt to deprecate some or all of these exports. + -- See haskell/Cabal#7974. + reexported-modules: + Distribution.Backpack, + Distribution.CabalSpecVersion, + Distribution.Compat.Binary, + Distribution.Compat.CharParsing, + Distribution.Compat.DList, + Distribution.Compat.Exception, + Distribution.Compat.Graph, + Distribution.Compat.Lens, + Distribution.Compat.MonadFail, + Distribution.Compat.Newtype, + Distribution.Compat.NonEmptySet, + Distribution.Compat.Parsing, + Distribution.Compat.Prelude, + Distribution.Compat.Semigroup, + Distribution.Compiler, + Distribution.FieldGrammar, + Distribution.FieldGrammar.Class, + Distribution.FieldGrammar.FieldDescrs, + Distribution.FieldGrammar.Newtypes, + Distribution.FieldGrammar.Parsec, + Distribution.FieldGrammar.Pretty, + Distribution.Fields, + Distribution.Fields.ConfVar, + Distribution.Fields.Field, + Distribution.Fields.Lexer, + Distribution.Fields.LexerMonad, + Distribution.Fields.ParseResult, + Distribution.Fields.Parser, + Distribution.Fields.Pretty, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.FieldGrammar, + Distribution.PackageDescription.Parsec, + Distribution.PackageDescription.PrettyPrint, + Distribution.PackageDescription.Quirks, + Distribution.PackageDescription.Utils, + Distribution.Parsec, + Distribution.Parsec.Error, + Distribution.Parsec.FieldLineStream, + Distribution.Parsec.Position, + Distribution.Parsec.Warning, + Distribution.Pretty, + Distribution.SPDX, + Distribution.SPDX.License, + Distribution.SPDX.LicenseExceptionId, + Distribution.SPDX.LicenseExpression, + Distribution.SPDX.LicenseId, + Distribution.SPDX.LicenseListVersion, + Distribution.SPDX.LicenseReference, + Distribution.System, + Distribution.Text, + Distribution.Types.AbiDependency, + Distribution.Types.AbiHash, + Distribution.Types.Benchmark, + Distribution.Types.Benchmark.Lens, + Distribution.Types.BenchmarkInterface, + Distribution.Types.BenchmarkType, + Distribution.Types.BuildInfo, + Distribution.Types.BuildInfo.Lens, + Distribution.Types.BuildType, + Distribution.Types.Component, + Distribution.Types.ComponentId, + Distribution.Types.ComponentName, + Distribution.Types.ComponentRequestedSpec, + Distribution.Types.CondTree, + Distribution.Types.Condition, + Distribution.Types.ConfVar, + Distribution.Types.Dependency, + Distribution.Types.DependencyMap, + Distribution.Types.DependencySatisfaction, + Distribution.Types.ExeDependency, + Distribution.Types.Executable, + Distribution.Types.Executable.Lens, + Distribution.Types.ExecutableScope, + Distribution.Types.ExposedModule, + Distribution.Types.Flag, + Distribution.Types.ForeignLib, + Distribution.Types.ForeignLib.Lens, + Distribution.Types.ForeignLibOption, + Distribution.Types.ForeignLibType, + Distribution.Types.GenericPackageDescription, + Distribution.Types.GenericPackageDescription.Lens, + Distribution.Types.HookedBuildInfo, + Distribution.Types.IncludeRenaming, + Distribution.Types.InstalledPackageInfo, + Distribution.Types.InstalledPackageInfo.Lens, + Distribution.Types.InstalledPackageInfo.FieldGrammar, + Distribution.Types.LegacyExeDependency, + Distribution.Types.Lens, + Distribution.Types.Library, + Distribution.Types.Library.Lens, + Distribution.Types.LibraryName, + Distribution.Types.LibraryVisibility, + Distribution.Types.MissingDependency, + Distribution.Types.MissingDependencyReason, + Distribution.Types.Mixin, + Distribution.Types.Module, + Distribution.Types.ModuleReexport, + Distribution.Types.ModuleRenaming, + Distribution.Types.MungedPackageId, + Distribution.Types.MungedPackageName, + Distribution.Types.PackageDescription, + Distribution.Types.PackageDescription.Lens, + Distribution.Types.PackageId, + Distribution.Types.PackageId.Lens, + Distribution.Types.PackageName, + Distribution.Types.PackageVersionConstraint, + Distribution.Types.PkgconfigDependency, + Distribution.Types.PkgconfigName, + Distribution.Types.PkgconfigVersion, + Distribution.Types.PkgconfigVersionRange, + Distribution.Types.SetupBuildInfo, + Distribution.Types.SetupBuildInfo.Lens, + Distribution.Types.SourceRepo, + Distribution.Types.SourceRepo.Lens, + Distribution.Types.TestSuite, + Distribution.Types.TestSuite.Lens, + Distribution.Types.TestSuiteInterface, + Distribution.Types.TestType, + Distribution.Types.UnitId, + Distribution.Types.UnqualComponentName, + Distribution.Types.Version, + Distribution.Types.VersionInterval, + Distribution.Types.VersionInterval.Legacy, + Distribution.Types.VersionRange, + Distribution.Types.VersionRange.Internal, + Distribution.Utils.Base62, + Distribution.Utils.Generic, + Distribution.Utils.MD5, + Distribution.Utils.Path, + Distribution.Utils.ShortText, + Distribution.Utils.String, + Distribution.Utils.Structured, + Distribution.Version, Language.Haskell.Extension - Distribution.Compat.Binary -- Parsec parser-related modules build-depends: -- transformers-0.4.0.0 doesn't have record syntax e.g. for Identity -- See also https://github.com/ekmett/transformers-compat/issues/35 - transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.6), - mtl >= 2.1 && < 2.3, - text (>= 1.2.3.0 && < 1.3) || (>= 2.0 && < 2.1), - parsec >= 3.1.13.0 && < 3.2 - exposed-modules: - Distribution.Compat.Parsing - Distribution.Compat.CharParsing - Distribution.FieldGrammar - Distribution.FieldGrammar.Class - Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Newtypes - Distribution.FieldGrammar.Parsec - Distribution.FieldGrammar.Pretty - Distribution.PackageDescription.FieldGrammar - Distribution.PackageDescription.Parsec - Distribution.PackageDescription.Quirks - Distribution.Parsec - Distribution.Parsec.Error - Distribution.Parsec.Position - Distribution.Parsec.Warning - Distribution.Parsec.FieldLineStream - Distribution.Fields - Distribution.Fields.ConfVar - Distribution.Fields.Field - Distribution.Fields.Lexer - Distribution.Fields.LexerMonad - Distribution.Fields.ParseResult - Distribution.Fields.Parser - Distribution.Fields.Pretty - - -- Lens functionality - exposed-modules: - Distribution.Compat.Lens - Distribution.Types.Lens - Distribution.Types.Benchmark.Lens - Distribution.Types.BuildInfo.Lens - Distribution.Types.Executable.Lens - Distribution.Types.ForeignLib.Lens - Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.InstalledPackageInfo.Lens - Distribution.Types.Library.Lens - Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId.Lens - Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo.Lens - Distribution.Types.TestSuite.Lens + , transformers (>= 0.3 && < 0.4) || (>=0.4.1.0 && <0.7) + , mtl >= 2.1 && < 2.4 + , parsec >= 3.1.13.0 && < 3.2 other-modules: Distribution.Backpack.PreExistingComponent @@ -322,29 +342,49 @@ Distribution.Backpack.UnifyM Distribution.Backpack.Id Distribution.Utils.UnionFind - Distribution.Utils.Base62 Distribution.Compat.Async Distribution.Compat.CopyFile Distribution.Compat.GetShortPathName - Distribution.Compat.MonadFail - Distribution.Compat.Prelude Distribution.Compat.SnocList Distribution.GetOpt Distribution.Lex - Distribution.Utils.String + Distribution.PackageDescription.Check.Common + Distribution.PackageDescription.Check.Conditional + Distribution.PackageDescription.Check.Monad + Distribution.PackageDescription.Check.Paths + Distribution.PackageDescription.Check.Target + Distribution.PackageDescription.Check.Warning Distribution.Simple.Build.Macros.Z + Distribution.Simple.Build.PackageInfoModule.Z Distribution.Simple.Build.PathsModule.Z + Distribution.Simple.GHC.Build + Distribution.Simple.GHC.Build.ExtraSources + Distribution.Simple.GHC.Build.Link + Distribution.Simple.GHC.Build.Modules + Distribution.Simple.GHC.Build.Utils Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.Internal Distribution.Simple.GHC.ImplInfo - Distribution.Simple.Utils.Json + Distribution.Simple.ConfigureScript + Distribution.Simple.Setup.Benchmark + Distribution.Simple.Setup.Build + Distribution.Simple.Setup.Clean + Distribution.Simple.Setup.Common + Distribution.Simple.Setup.Config + Distribution.Simple.Setup.Copy + Distribution.Simple.Setup.Global + Distribution.Simple.Setup.Haddock + Distribution.Simple.Setup.Hscolour + Distribution.Simple.Setup.Install + Distribution.Simple.Setup.Register + Distribution.Simple.Setup.Repl + Distribution.Simple.Setup.SDist + Distribution.Simple.Setup.Test Distribution.ZinzaPrelude Paths_Cabal - if flag(bundled-binary-generic) - other-modules: - Distribution.Compat.Binary.Class - Distribution.Compat.Binary.Generic + autogen-modules: + Paths_Cabal other-extensions: BangPatterns @@ -361,8 +401,10 @@ GeneralizedNewtypeDeriving ImplicitParams KindSignatures + LambdaCase NondecreasingIndentation OverloadedStrings + PatternSynonyms RankNTypes RecordWildCards ScopedTypeVariables @@ -372,6 +414,3 @@ TypeOperators TypeSynonymInstances UndecidableInstances - - if impl(ghc >= 7.11) - other-extensions: PatternSynonyms diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,16 +1,55 @@ +# 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.1.0.md + +# 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.16.0.0.md + +# 3.14.2.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) April 2025 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.2.0.md + +# 3.14.1.0 [Hécate](mailto:hecate+github@glitchbra.in) November 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.1.0.md + +# 3.14.0.0 [Hécate](mailto:hecate+github@glitchbra.in) September 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.14.0.0.md + +# 3.12.1.0 [Artem Pelenitsyn](mailto:a.pelenitsyn@gmail.com) June 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.1.0.md + +# 3.12.0.0 [Francesco Ariis](mailto:fa-ml@ariis.it) May 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.12.0.0.md + +# 3.10.3.0 [Hécate](mailto:hecate+github@glitchbra.in) January 2024 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.3.0.md + +# 3.10.2.1 [Hécate](mailto:hecate+github@glitchbra.in) October 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.1.md + +# 3.10.2.0 [Hécate](mailto:hecate+github@glitchbra.in) August 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.2.0.md + +# 3.10.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) March 2023 +* See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.10.1.0.md + +# 3.8.1.0 [Mikolaj Konarski](mailto:mikolaj@well-typed.com) August 2022 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.8.1.0.md + # 3.6.3.0 March 2022 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.3.0.md -# 3.6.2.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) October 2021 +# 3.6.2.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.2.0.md -# 3.6.1.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021 +# 3.6.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.1.0.md -# 3.6.0.0 [Emily Pillmore](mailgo:emilypi@cohomolo.gy) August 2021 +# 3.6.0.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) August 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.6.0.0.md -# 3.4.0.0 [Oleg Grenrus](mailgo:oleg.grnerus@iki.fi) February 2021 +# 3.4.1.0 [Emily Pillmore](mailto:emilypi@cohomolo.gy) October 2021 + * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.1.0.md + +# 3.4.0.0 [Oleg Grenrus](mailto:oleg.grnerus@iki.fi) February 2021 * See https://github.com/haskell/cabal/blob/master/release-notes/Cabal-3.4.0.0.md # 3.2.1.0 [Oleg Grenrus](mailto:oleg.grenris@iki.fi) October 2020 @@ -743,7 +782,7 @@ * Many checks added for common mistakes * New `--package-db=` option for specific package databases * Many internal changes to support cabal-install - * Stricter parsing for version strings, eg dissalows "1.05" + * Stricter parsing for version strings, eg disallows "1.05" * Improved user guide introduction * Programatica support removed * New options `--program-prefix/suffix` allows eg versioned programs diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2020, Cabal Development Team. +Copyright (c) 2003-2025, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,17 +6,17 @@ If you also want the `cabal` command-line program, you need the [cabal-install] package in addition to this library. -[cabal-install]: ../cabal-install/README.md +[cabal-install]: ../cabal-install More information ================ -Please see the [Cabal web site] for the [user guide] and [API +Please see the [Cabal web site], the [user guide] and the [API documentation]. There is additional information available on the [development wiki]. [user guide]: http://www.haskell.org/cabal/users-guide -[API documentation]: http://www.haskell.org/cabal/release/cabal-latest/doc/API/Cabal/Distribution-Simple.html +[API documentation]: https://hackage.haskell.org/package/Cabal/docs/Distribution-Simple.html [development wiki]: https://github.com/haskell/cabal/wiki @@ -34,8 +34,8 @@ [Hackage]. You may have a favourite Cabal bug or limitation. Look at Cabal's [bug tracker]. Ensure that the problem is reported there and adequately described. Comment on the issue to report how much of a -problem the bug is for you. Subscribe to the issues's notifications to -discussed requirements and keep informed on progress. For feature +problem the bug is for you. Subscribe to the issue's notifications to +discuss requirements and keep informed on progress. For feature requests, it is helpful if there is a description of how you would expect to interact with the new feature. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,4 +1,5 @@ import Distribution.Simple + main :: IO () main = defaultMain diff --git a/src/Distribution/Backpack.hs b/src/Distribution/Backpack.hs deleted file mode 100644 --- a/src/Distribution/Backpack.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} - --- | This module defines the core data types for Backpack. For more --- details, see: --- --- - -module Distribution.Backpack ( - -- * OpenUnitId - OpenUnitId(..), - openUnitIdFreeHoles, - mkOpenUnitId, - - -- * DefUnitId - DefUnitId, - unDefUnitId, - mkDefUnitId, - - -- * OpenModule - OpenModule(..), - openModuleFreeHoles, - - -- * OpenModuleSubst - OpenModuleSubst, - dispOpenModuleSubst, - dispOpenModuleSubstEntry, - parsecOpenModuleSubst, - parsecOpenModuleSubstEntry, - openModuleSubstFreeHoles, - - -- * Conversions to 'UnitId' - abstractUnitId, - hashModuleSubst, -) where - -import Distribution.Compat.Prelude hiding (mod) -import Distribution.Parsec -import Distribution.Pretty -import Prelude () -import Text.PrettyPrint (hcat) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -import Distribution.ModuleName -import Distribution.Types.ComponentId -import Distribution.Types.Module -import Distribution.Types.UnitId -import Distribution.Utils.Base62 - -import qualified Data.Map as Map -import qualified Data.Set as Set - ------------------------------------------------------------------------ --- OpenUnitId - --- | An 'OpenUnitId' describes a (possibly partially) instantiated --- Backpack component, with a description of how the holes are filled --- in. Unlike 'OpenUnitId', the 'ModuleSubst' is kept in a structured --- form that allows for substitution (which fills in holes.) This form --- of unit cannot be installed. It must first be converted to a --- 'UnitId'. --- --- In the absence of Backpack, there are no holes to fill, so any such --- component always has an empty module substitution; thus we can lossly --- represent it as an 'OpenUnitId uid'. --- --- For a source component using Backpack, however, there is more --- structure as components may be parametrized over some signatures, and --- these \"holes\" may be partially or wholly filled. --- --- OpenUnitId plays an important role when we are mix-in linking, --- and is recorded to the installed packaged database for indefinite --- packages; however, for compiled packages that are fully instantiated, --- we instantiate 'OpenUnitId' into 'UnitId'. --- --- For more details see the Backpack spec --- --- - -data OpenUnitId - -- | Identifies a component which may have some unfilled holes; - -- specifying its 'ComponentId' and its 'OpenModuleSubst'. - -- TODO: Invariant that 'OpenModuleSubst' is non-empty? - -- See also the Text instance. - = IndefFullUnitId ComponentId OpenModuleSubst - -- | Identifies a fully instantiated component, which has - -- been compiled and abbreviated as a hash. The embedded 'UnitId' - -- MUST NOT be for an indefinite component; an 'OpenUnitId' - -- is guaranteed not to have any holes. - | DefiniteUnitId DefUnitId - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) --- TODO: cache holes? - -instance Binary OpenUnitId -instance Structured OpenUnitId -instance NFData OpenUnitId where - rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst - rnf (DefiniteUnitId uid) = rnf uid - -instance Pretty OpenUnitId where - pretty (IndefFullUnitId cid insts) - -- TODO: arguably a smart constructor to enforce invariant would be - -- better - | Map.null insts = pretty cid - | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts) - pretty (DefiniteUnitId uid) = pretty uid - --- | --- --- >>> eitherParsec "foobar" :: Either String OpenUnitId ---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"})) --- --- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId --- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))])) --- -instance Parsec OpenUnitId where - parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec - where - parseOpenUnitId = do - cid <- parsec - insts <- P.between (P.char '[') (P.char ']') - parsecOpenModuleSubst - return (IndefFullUnitId cid insts) - --- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'. -openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName -openUnitIdFreeHoles (IndefFullUnitId _ insts) = openModuleSubstFreeHoles insts -openUnitIdFreeHoles _ = Set.empty - --- | Safe constructor from a UnitId. The only way to do this safely --- is if the instantiation is provided. -mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId -mkOpenUnitId uid cid insts = - if Set.null (openModuleSubstFreeHoles insts) - then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds! - else IndefFullUnitId cid insts - ------------------------------------------------------------------------ --- DefUnitId - --- | Create a 'DefUnitId' from a 'ComponentId' and an instantiation --- with no holes. -mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId -mkDefUnitId cid insts = - unsafeMkDefUnitId (mkUnitId - (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts))) - -- impose invariant! - ------------------------------------------------------------------------ --- OpenModule - --- | Unlike a 'Module', an 'OpenModule' is either an ordinary --- module from some unit, OR an 'OpenModuleVar', representing a --- hole that needs to be filled in. Substitutions are over --- module variables. -data OpenModule - = OpenModule OpenUnitId ModuleName - | OpenModuleVar ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary OpenModule -instance Structured OpenModule - -instance NFData OpenModule where - rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name - rnf (OpenModuleVar mod_name) = rnf mod_name - -instance Pretty OpenModule where - pretty (OpenModule uid mod_name) = - hcat [pretty uid, Disp.text ":", pretty mod_name] - pretty (OpenModuleVar mod_name) = - hcat [Disp.char '<', pretty mod_name, Disp.char '>'] - --- | --- --- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule --- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL")) --- -instance Parsec OpenModule where - parsec = parsecModuleVar <|> parsecOpenModule - where - parsecOpenModule = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (OpenModule uid mod_name) - - parsecModuleVar = do - _ <- P.char '<' - mod_name <- parsec - _ <- P.char '>' - return (OpenModuleVar mod_name) - --- | Get the set of holes ('ModuleVar') embedded in a 'Module'. -openModuleFreeHoles :: OpenModule -> Set ModuleName -openModuleFreeHoles (OpenModuleVar mod_name) = Set.singleton mod_name -openModuleFreeHoles (OpenModule uid _n) = openUnitIdFreeHoles uid - ------------------------------------------------------------------------ --- OpenModuleSubst - --- | An explicit substitution on modules. --- --- NB: These substitutions are NOT idempotent, for example, a --- valid substitution is (A -> B, B -> A). -type OpenModuleSubst = Map ModuleName OpenModule - --- | Pretty-print the entries of a module substitution, suitable --- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@. -dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc -dispOpenModuleSubst subst - = Disp.hcat - . Disp.punctuate Disp.comma - $ map dispOpenModuleSubstEntry (Map.toAscList subst) - --- | Pretty-print a single entry of a module substitution. -dispOpenModuleSubstEntry :: (ModuleName, OpenModule) -> Disp.Doc -dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - --- | Inverse to 'dispModSubst'. --- --- @since 2.2 -parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst -parsecOpenModuleSubst = fmap Map.fromList - . flip P.sepBy (P.char ',') - $ parsecOpenModuleSubstEntry - --- | Inverse to 'dispModSubstEntry'. --- --- @since 2.2 -parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule) -parsecOpenModuleSubstEntry = - do k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'. --- This is NOT the domain of the substitution. -openModuleSubstFreeHoles :: OpenModuleSubst -> Set ModuleName -openModuleSubstFreeHoles insts = Set.unions (map openModuleFreeHoles (Map.elems insts)) - ------------------------------------------------------------------------ --- Conversions to UnitId - --- | When typechecking, we don't demand that a freshly instantiated --- 'IndefFullUnitId' be compiled; instead, we just depend on the --- installed indefinite unit installed at the 'ComponentId'. -abstractUnitId :: OpenUnitId -> UnitId -abstractUnitId (DefiniteUnitId def_uid) = unDefUnitId def_uid -abstractUnitId (IndefFullUnitId cid _) = newSimpleUnitId cid - --- | Take a module substitution and hash it into a string suitable for --- 'UnitId'. Note that since this takes 'Module', not 'OpenModule', --- you are responsible for recursively converting 'OpenModule' --- into 'Module'. See also "Distribution.Backpack.ReadyComponent". -hashModuleSubst :: Map ModuleName Module -> Maybe String -hashModuleSubst subst - | Map.null subst = Nothing - | otherwise = - Just . hashToBase62 $ - concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n" - | (mod_name, m) <- Map.toList subst] diff --git a/src/Distribution/Backpack/ComponentsGraph.hs b/src/Distribution/Backpack/ComponentsGraph.hs --- a/src/Distribution/Backpack/ComponentsGraph.hs +++ b/src/Distribution/Backpack/ComponentsGraph.hs @@ -1,24 +1,24 @@ -- | See -module Distribution.Backpack.ComponentsGraph ( - ComponentsGraph, - ComponentsWithDeps, - mkComponentsGraph, - componentsGraphToList, - dispComponentsWithDeps, - componentCycleMsg -) where +module Distribution.Backpack.ComponentsGraph + ( ComponentsGraph + , ComponentsWithDeps + , mkComponentsGraph + , componentsGraphToList + , dispComponentsWithDeps + , componentCycleMsg + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.Compat.Graph (Graph, Node (..)) +import qualified Distribution.Compat.Graph as Graph +import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Compat.Graph (Graph, Node(..)) -import qualified Distribution.Compat.Graph as Graph -import qualified Distribution.Compat.NonEmptySet as NES import Distribution.Utils.Generic import Distribution.Pretty (pretty) @@ -30,68 +30,76 @@ -- | A graph of source-level components by their source-level -- dependencies --- type ComponentsGraph = Graph (Node ComponentName Component) -- | A list of components associated with the source level -- dependencies between them. --- type ComponentsWithDeps = [(Component, [ComponentName])] -- | Pretty-print 'ComponentsWithDeps'. --- dispComponentsWithDeps :: ComponentsWithDeps -> Doc dispComponentsWithDeps graph = - vcat [ hang (text "component" <+> pretty (componentName c)) 4 - (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ]) - | (c, cdeps) <- graph ] + vcat + [ hang + (text "component" <+> pretty (componentName c)) + 4 + (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps]) + | (c, cdeps) <- graph + ] -- | Create a 'Graph' of 'Component', or report a cycle if there is a -- problem. --- -mkComponentsGraph :: ComponentRequestedSpec - -> PackageDescription - -> Either [ComponentName] ComponentsGraph +mkComponentsGraph + :: ComponentRequestedSpec + -> PackageDescription + -> Either [ComponentName] ComponentsGraph mkComponentsGraph enabled pkg_descr = - let g = Graph.fromDistinctList - [ N c (componentName c) (componentDeps c) - | c <- pkgBuildableComponents pkg_descr - , componentEnabled enabled c ] - in case Graph.cycles g of - [] -> Right g - ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ] + let g = + Graph.fromDistinctList + [ N c (componentName c) (componentDeps c) + | c <- pkgBuildableComponents pkg_descr + , componentEnabled enabled c + ] + in case Graph.cycles g of + [] -> Right g + ccycles -> Left [componentName c | N c _ _ <- concat ccycles] where -- The dependencies for the given component componentDeps component = - toolDependencies ++ libDependencies + toolDependencies ++ libDependencies where bi = componentBuildInfo component toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi libDependencies = do - Dependency pkgname _ lns <- targetBuildDepends bi - guard (pkgname == packageName pkg_descr) + Dependency pkgname _ lns <- targetBuildDepends bi + guard (pkgname == packageName pkg_descr) - ln <- NES.toList lns - return (CLibName ln) + ln <- NES.toList lns + return (CLibName ln) -- | Given the package description and a 'PackageDescription' (used -- to determine if a package name is internal or not), sort the -- components in dependency order (fewest dependencies first). This is -- NOT necessarily the build order (although it is in the absence of -- Backpack.) --- -componentsGraphToList :: ComponentsGraph - -> ComponentsWithDeps +componentsGraphToList + :: ComponentsGraph + -> ComponentsWithDeps componentsGraphToList = - map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort + map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort -- | Error message when there is a cycle; takes the SCC of components. componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc componentCycleMsg pn cnames = - text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:" - $$ - text (intercalate " depends on " - [ "'" ++ showComponentName cname ++ "'" - | cname <- cnames ++ maybeToList (safeHead cnames) ]) + text "Components in the package" + <+> pretty pn + <+> text "depend on each other in a cyclic way:" + $$ text + ( intercalate + " depends on " + [ "'" ++ showComponentName cname ++ "'" + | cname <- cnames ++ maybeToList (safeHead cnames) + ] + ) diff --git a/src/Distribution/Backpack/Configure.hs b/src/Distribution/Backpack/Configure.hs --- a/src/Distribution/Backpack/Configure.hs +++ b/src/Distribution/Backpack/Configure.hs @@ -1,56 +1,58 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE NondecreasingIndentation #-} -- | See -- -- WARNING: The contents of this module are HIGHLY experimental. -- We may refactor it under you. -module Distribution.Backpack.Configure ( - configureComponentLocalBuildInfos, -) where +module Distribution.Backpack.Configure + ( configureComponentLocalBuildInfos + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId -import Distribution.Backpack.PreExistingComponent +import Distribution.Backpack.ComponentsGraph import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.Id import Distribution.Backpack.LinkedComponent +import Distribution.Backpack.PreExistingComponent import Distribution.Backpack.ReadyComponent -import Distribution.Backpack.ComponentsGraph -import Distribution.Backpack.Id -import Distribution.Simple.Compiler -import Distribution.Package +import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (Graph, IsNode (..)) +import qualified Distribution.Compat.Graph as Graph +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , emptyInstalledPackageInfo + ) import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.InstalledPackageInfo (InstalledPackageInfo - ,emptyInstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription import Distribution.ModuleName -import Distribution.Simple.Setup as Setup +import Distribution.Package +import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) +import Distribution.Simple.Compiler +import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentRequestedSpec import Distribution.Types.ComponentInclude +import Distribution.Types.ComponentRequestedSpec import Distribution.Types.MungedPackageName -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Utils.LogProgress +import Distribution.Verbosity import Data.Either - ( lefts ) -import qualified Data.Set as Set + ( lefts + ) import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty import Text.PrettyPrint @@ -59,144 +61,235 @@ ------------------------------------------------------------------------------ configureComponentLocalBuildInfos - :: Verbosity - -> Bool -- use_external_internal_deps - -> ComponentRequestedSpec - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> [PreExistingComponent] - -> FlagAssignment -- configConfigurationsFlags - -> [(ModuleName, Module)] -- configInstantiateWith - -> InstalledPackageIndex - -> Compiler - -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) + :: Verbosity + -> Bool -- use_external_internal_deps + -> ComponentRequestedSpec + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> FlagAssignment -- configConfigurationsFlags + -> [(ModuleName, Module)] -- configInstantiateWith + -> InstalledPackageIndex + -> Compiler + -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex) configureComponentLocalBuildInfos - verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr - prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do + verbosity + use_external_internal_deps + enabled + deterministic + ipid_flag + cid_flag + pkg_descr + (prePkgDeps, promisedPkgDeps) + flags + instantiate_with + installedPackageSet + comp = do -- NB: In single component mode, this returns a *single* component. -- In this graph, the graph is NOT closed. graph0 <- case mkComponentsGraph enabled pkg_descr of - Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) - Right g -> return (componentsGraphToList g) - infoProgress $ hang (text "Source component graph:") 4 - (dispComponentsWithDeps graph0) + Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle) + Right g -> return (componentsGraphToList g) + infoProgress $ + hang + (text "Source component graph:") + 4 + (dispComponentsWithDeps graph0) - let conf_pkg_map = Map.fromListWith Map.union - [(pc_pkgname pkg, - Map.singleton (pc_compname pkg) - (AnnotatedId { - ann_id = pc_cid pkg, - ann_pid = packageId pkg, - ann_cname = pc_compname pkg - })) - | pkg <- prePkgDeps] - graph1 <- toConfiguredComponents use_external_internal_deps - flagAssignment - deterministic ipid_flag cid_flag pkg_descr - conf_pkg_map (map fst graph0) - infoProgress $ hang (text "Configured component graph:") 4 - (vcat (map dispConfiguredComponent graph1)) + let conf_pkg_map = + Map.fromListWith + Map.union + $ + -- Normal dependencies + [ ( pc_pkgname pkg + , Map.singleton + (pc_compname pkg) + ( AnnotatedId + { ann_id = pc_cid pkg + , ann_pid = packageId pkg + , ann_cname = pc_compname pkg + } + ) + ) + | pkg <- prePkgDeps + ] + ++ + -- Promised dependencies + [ (pkg, Map.singleton (ann_cname aid) aid) + | ConfiguredPromisedComponent pkg aid <- promisedPkgDeps + ] + graph1 <- + toConfiguredComponents + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + conf_pkg_map + (map fst graph0) + infoProgress $ + hang + (text "Configured component graph:") + 4 + (vcat (map dispConfiguredComponent graph1)) - let shape_pkg_map = Map.fromList + let shape_pkg_map = + Map.fromList [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg)) - | pkg <- prePkgDeps] + | pkg <- prePkgDeps + ] + `Map.union` Map.fromList + [ ( ann_id aid + , + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId (unComponentId (ann_id aid))) + ) + , emptyModuleShape + ) + ) + | ConfiguredPromisedComponent _ aid <- promisedPkgDeps + ] uid_lookup def_uid - | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid - = FullUnitId (Installed.installedComponentId pkg) - (Map.fromList (Installed.instantiatedWith pkg)) - | otherwise = error ("uid_lookup: " ++ prettyShow uid) - where uid = unDefUnitId def_uid - graph2 <- toLinkedComponents verbosity uid_lookup - (package pkg_descr) shape_pkg_map graph1 + | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid = + FullUnitId + (Installed.installedComponentId pkg) + (Map.fromList (Installed.instantiatedWith pkg)) + | otherwise = error ("uid_lookup: " ++ prettyShow uid) + where + uid = unDefUnitId def_uid + graph2 <- + toLinkedComponents + verbosity + (not (null promisedPkgDeps)) + uid_lookup + (package pkg_descr) + shape_pkg_map + graph1 infoProgress $ - hang (text "Linked component graph:") 4 - (vcat (map dispLinkedComponent graph2)) + hang + (text "Linked component graph:") + 4 + (vcat (map dispLinkedComponent graph2)) - let pid_map = Map.fromList $ + let pid_map = + Map.fromList $ [ (pc_uid pkg, pc_munged_id pkg) - | pkg <- prePkgDeps] ++ - [ (Installed.installedUnitId pkg, mungedId pkg) - | (_, Module uid _) <- instantiate_with - , Just pkg <- [PackageIndex.lookupUnitId - installedPackageSet (unDefUnitId uid)] ] + | pkg <- prePkgDeps + ] + ++ [ (Installed.installedUnitId pkg, mungedId pkg) + | (_, Module uid _) <- instantiate_with + , Just pkg <- + [ PackageIndex.lookupUnitId + installedPackageSet + (unDefUnitId uid) + ] + ] subst = Map.fromList instantiate_with graph3 = toReadyComponents pid_map subst graph2 graph4 = Graph.revTopSort (Graph.fromDistinctList graph3) - infoProgress $ hang (text "Ready component graph:") 4 - (vcat (map dispReadyComponent graph4)) + infoProgress $ + hang + (text "Ready component graph:") + 4 + (vcat (map dispReadyComponent graph4)) - toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4 + toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4 ------------------------------------------------------------------------------ -- ComponentLocalBuildInfo ------------------------------------------------------------------------------ toComponentLocalBuildInfos - :: Compiler - -> InstalledPackageIndex -- FULL set - -> PackageDescription - -> [PreExistingComponent] -- external package deps - -> [ReadyComponent] - -> LogProgress ([ComponentLocalBuildInfo], - InstalledPackageIndex) -- only relevant packages + :: Compiler + -> InstalledPackageIndex -- FULL set + -> [ConfiguredPromisedComponent] + -> PackageDescription + -> [PreExistingComponent] -- external package deps + -> [ReadyComponent] + -> LogProgress + ( [ComponentLocalBuildInfo] + , InstalledPackageIndex -- only relevant packages + ) toComponentLocalBuildInfos - comp installedPackageSet pkg_descr externalPkgDeps graph = do + comp + installedPackageSet + promisedPkgDeps + pkg_descr + externalPkgDeps + graph = do -- Check and make sure that every instantiated component exists. -- We have to do this now, because prior to linking/instantiating -- we don't actually know what the full set of 'UnitId's we need -- are. - let -- TODO: This is actually a bit questionable performance-wise, - -- since we will pay for the ALL installed packages even if - -- they are not related to what we are building. This was true - -- in the old configure code. - external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - external_graph = Graph.fromDistinctList - . map Left - $ PackageIndex.allPackages installedPackageSet - internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) - internal_graph = Graph.fromDistinctList - . map Right - $ graph - combined_graph = Graph.unionRight external_graph internal_graph - local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") - $ Graph.closure combined_graph (map nodeKey graph) - -- The database of transitively reachable installed packages that the - -- external components the package (as a whole) depends on. This will be - -- used in several ways: - -- - -- * We'll use it to do a consistency check so we're not depending - -- on multiple versions of the same package (TODO: someday relax - -- this for private dependencies.) See right below. - -- - -- * We'll pass it on in the LocalBuildInfo, where preprocessors - -- and other things will incorrectly use it to determine what - -- the include paths and everything should be. - -- - packageDependsIndex = PackageIndex.fromList (lefts local_graph) - fullIndex = Graph.fromDistinctList local_graph + let + -- TODO: This is actually a bit questionable performance-wise, + -- since we will pay for the ALL installed packages even if + -- they are not related to what we are building. This was true + -- in the old configure code. + external_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + external_graph = + Graph.fromDistinctList + . map Left + $ PackageIndex.allPackages installedPackageSet + internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent) + internal_graph = + Graph.fromDistinctList + . map Right + $ graph + combined_graph = Graph.unionRight external_graph internal_graph + local_graph = + fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $ + Graph.closure combined_graph (map nodeKey graph) + -- The database of transitively reachable installed packages that the + -- external components the package (as a whole) depends on. This will be + -- used in several ways: + -- + -- * We'll use it to do a consistency check so we're not depending + -- on multiple versions of the same package (TODO: someday relax + -- this for private dependencies.) See right below. + -- + -- * We'll pass it on in the LocalBuildInfo, where preprocessors + -- and other things will incorrectly use it to determine what + -- the include paths and everything should be. + -- + packageDependsIndex = PackageIndex.fromList (lefts local_graph) + fullIndex = Graph.fromDistinctList local_graph + case Graph.broken fullIndex of - [] -> return () - broken -> - -- TODO: ppr this - dieProgress . text $ - "The following packages are broken because other" - ++ " packages they depend on are missing. These broken " - ++ "packages must be rebuilt before they can be used.\n" - -- TODO: Undupe. - ++ unlines [ "installed package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Left pkg, deps) <- broken ] - ++ unlines [ "planned package " - ++ prettyShow (packageId pkg) - ++ " is broken due to missing package " - ++ intercalate ", " (map prettyShow deps) - | (Right pkg, deps) <- broken ] + [] -> return () + -- If there are promised dependencies, we don't know what the dependencies + -- of these are and that can easily lead to a broken graph. So assume that + -- any promised package is not broken (ie all its dependencies, transitively, + -- will be there). That's a promise. + broken + | not (null promisedPkgDeps) -> return () + | otherwise -> + -- TODO: ppr this + dieProgress . text $ + "The following packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + -- TODO: Undupe. + ++ unlines + [ "installed package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Left pkg, deps) <- broken + ] + ++ unlines + [ "planned package " + ++ prettyShow (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map prettyShow deps) + | (Right pkg, deps) <- broken + ] -- In this section, we'd like to look at the 'packageDependsIndex' -- and see if we've picked multiple versions of the same @@ -213,25 +306,34 @@ -- -- TODO: This is probably wrong for Backpack let pseudoTopPkg :: InstalledPackageInfo - pseudoTopPkg = emptyInstalledPackageInfo { - Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr), - Installed.sourcePackageId = packageId pkg_descr, - Installed.depends = map pc_uid externalPkgDeps - } + pseudoTopPkg = + emptyInstalledPackageInfo + { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr) + , Installed.sourcePackageId = packageId pkg_descr + , Installed.depends = map pc_uid externalPkgDeps + } case PackageIndex.dependencyInconsistencies - . PackageIndex.insert pseudoTopPkg - $ packageDependsIndex of + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of [] -> return () inconsistencies -> warnProgress $ - hang (text "This package indirectly depends on multiple versions of the same" <+> - text "package. This is very likely to cause a compile failure.") 2 - (vcat [ text "package" <+> pretty (packageName user) <+> - parens (pretty (installedUnitId user)) <+> text "requires" <+> - pretty inst - | (_dep_key, insts) <- inconsistencies - , (inst, users) <- insts - , user <- users ]) + hang + ( text "This package indirectly depends on multiple versions of the same" + <+> text "package. This is very likely to cause a compile failure." + ) + 2 + ( vcat + [ text "package" + <+> pretty (packageName user) + <+> parens (pretty (installedUnitId user)) + <+> text "requires" + <+> pretty inst + | (_dep_key, insts) <- inconsistencies + , (inst, users) <- insts + , user <- users + ] + ) let clbis = mkLinkedComponentsLocalBuildInfo comp graph -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps) return (clbis, packageDependsIndex) @@ -241,119 +343,124 @@ -- -- This conversion is lossy; we lose some invariants from ReadyComponent mkLinkedComponentsLocalBuildInfo - :: Compiler - -> [ReadyComponent] - -> [ComponentLocalBuildInfo] + :: Compiler + -> [ReadyComponent] + -> [ComponentLocalBuildInfo] mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs where internalUnits = Set.fromList (map rc_uid rcs) isInternal x = Set.member x internalUnits go rc = case rc_component rc of - CLib lib -> - let convModuleExport (modname', (Module uid modname)) - | this_uid == unDefUnitId uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' - (Just (OpenModule (DefiniteUnitId uid) modname)) - convOpenModuleExport (modname', modu@(OpenModule uid modname)) - | uid == this_open_uid - , modname' == modname - = Installed.ExposedModule modname' Nothing - | otherwise - = Installed.ExposedModule modname' (Just modu) - convOpenModuleExport (_, OpenModuleVar _) - = error "convOpenModuleExport: top-level modvar" - exports = + CLib lib -> + let convModuleExport (modname', (Module uid modname)) + | this_uid == unDefUnitId uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule + modname' + (Just (OpenModule (DefiniteUnitId uid) modname)) + convOpenModuleExport (modname', modu@(OpenModule uid modname)) + | uid == this_open_uid + , modname' == modname = + Installed.ExposedModule modname' Nothing + | otherwise = + Installed.ExposedModule modname' (Just modu) + convOpenModuleExport (_, OpenModuleVar _) = + error "convOpenModuleExport: top-level modvar" + exports = -- Loses invariants case rc_i rc of - Left indefc -> map convOpenModuleExport - $ Map.toList (indefc_provides indefc) - Right instc -> map convModuleExport - $ Map.toList (instc_provides instc) - insts = + Left indefc -> + map convOpenModuleExport $ + Map.toList (indefc_provides indefc) + Right instc -> + map convModuleExport $ + Map.toList (instc_provides instc) + insts = case rc_i rc of - Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ] - Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m') - | (m, Module uid' m') <- instc_insts instc ] - - compat_name = MungedPackageName (packageName rc) (libName lib) - compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc] + Right instc -> + [ (m, OpenModule (DefiniteUnitId uid') m') + | (m, Module uid' m') <- instc_insts instc + ] - in LibComponentLocalBuildInfo { - componentPackageDeps = cpds, - componentUnitId = this_uid, - componentComponentId = this_cid, - componentInstantiatedWith = insts, - componentIsIndefinite_ = is_indefinite, - componentLocalName = cname, - componentInternalDeps = internal_deps, - componentExeDeps = exe_deps, - componentIncludes = includes, - componentExposedModules = exports, - componentIsPublic = rc_public rc, - componentCompatPackageKey = compat_key, - componentCompatPackageName = compat_name - } - CFLib _ -> - FLibComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CExe _ -> - ExeComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CTest _ -> - TestComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - CBench _ -> - BenchComponentLocalBuildInfo { - componentUnitId = this_uid, - componentComponentId = this_cid, - componentLocalName = cname, - componentPackageDeps = cpds, - componentExeDeps = exe_deps, - componentInternalDeps = internal_deps, - componentIncludes = includes - } - where - this_uid = rc_uid rc - this_open_uid = rc_open_uid rc - this_cid = rc_cid rc - cname = componentName (rc_component rc) - cpds = rc_depends rc - exe_deps = map ann_id $ rc_exe_deps rc - is_indefinite = - case rc_i rc of + compat_name = MungedPackageName (packageName rc) (libName lib) + compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid + in LibComponentLocalBuildInfo + { componentPackageDeps = cpds + , componentUnitId = this_uid + , componentComponentId = this_cid + , componentInstantiatedWith = insts + , componentIsIndefinite_ = is_indefinite + , componentLocalName = cname + , componentInternalDeps = internal_deps + , componentExeDeps = exe_deps + , componentIncludes = includes + , componentExposedModules = exports + , componentIsPublic = rc_public rc + , componentCompatPackageKey = compat_key + , componentCompatPackageName = compat_name + } + CFLib _ -> + FLibComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CExe _ -> + ExeComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CTest _ -> + TestComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + CBench _ -> + BenchComponentLocalBuildInfo + { componentUnitId = this_uid + , componentComponentId = this_cid + , componentLocalName = cname + , componentPackageDeps = cpds + , componentExeDeps = exe_deps + , componentInternalDeps = internal_deps + , componentIncludes = includes + } + where + this_uid = rc_uid rc + this_open_uid = rc_open_uid rc + this_cid = rc_cid rc + cname = componentName (rc_component rc) + cpds = rc_depends rc + exe_deps = map ann_id $ rc_exe_deps rc + is_indefinite = + case rc_i rc of Left _ -> True Right _ -> False - includes = - map (\ci -> (ci_id ci, ci_renaming ci)) $ + includes = + map (\ci -> (ci_id ci, ci_renaming ci)) $ case rc_i rc of - Left indefc -> - indefc_includes indefc - Right instc -> - map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) }) - (instc_includes instc) - internal_deps = filter isInternal (nodeNeighbors rc) + Left indefc -> + indefc_includes indefc + Right instc -> + map + (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)}) + (instc_includes instc) + internal_deps = filter isInternal (nodeNeighbors rc) diff --git a/src/Distribution/Backpack/ConfiguredComponent.hs b/src/Distribution/Backpack/ConfiguredComponent.hs --- a/src/Distribution/Backpack/ConfiguredComponent.hs +++ b/src/Distribution/Backpack/ConfiguredComponent.hs @@ -1,80 +1,66 @@ -{-# LANGUAGE PatternGuards #-} -- | See -module Distribution.Backpack.ConfiguredComponent ( - ConfiguredComponent(..), - cc_name, - cc_cid, - cc_pkgid, - toConfiguredComponent, - toConfiguredComponents, - dispConfiguredComponent, - - ConfiguredComponentMap, - extendConfiguredComponentMap, - - -- TODO: Should go somewhere else - newPackageDepsBehaviour -) where +module Distribution.Backpack.ConfiguredComponent + ( ConfiguredComponent (..) + , cc_name + , cc_cid + , cc_pkgid + , toConfiguredComponent + , toConfiguredComponents + , dispConfiguredComponent + , ConfiguredComponentMap + , extendConfiguredComponentMap + -- TODO: Should go somewhere else + , newPackageDepsBehaviour + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack.Id import Distribution.CabalSpecVersion -import Distribution.Types.AnnotatedId -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentId -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Mixin -import Distribution.Types.ComponentName -import Distribution.Types.LibraryName -import Distribution.Types.ComponentInclude import Distribution.Package import Distribution.PackageDescription import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Setup as Setup +import Distribution.Simple.Flag (Flag) import Distribution.Simple.LocalBuildInfo +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import Distribution.Utils.Generic import Distribution.Utils.LogProgress import Distribution.Utils.MapAccum -import Distribution.Utils.Generic import Control.Monad +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Distribution.Compat.NonEmptySet as NonEmptySet -import qualified Data.Map as Map import Distribution.Pretty -import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$)) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$)) import qualified Text.PrettyPrint as PP -- | A configured component, we know exactly what its 'ComponentId' is, -- and the 'ComponentId's of the things it depends on. -data ConfiguredComponent - = ConfiguredComponent { - -- | Unique identifier of component, plus extra useful info. - cc_ann_id :: AnnotatedId ComponentId, - -- | The fragment of syntax from the Cabal file describing this - -- component. - cc_component :: Component, - -- | Is this the public library component of the package? - -- (If we invoke Setup with an instantiation, this is the - -- component the instantiation applies to.) - -- Note that in one-component configure mode, this is - -- always True, because any component is the "public" one.) - cc_public :: Bool, - -- | Dependencies on executables from @build-tools@ and - -- @build-tool-depends@. - cc_exe_deps :: [AnnotatedId ComponentId], - -- | The mixins of this package, including both explicit (from - -- the @mixins@ field) and implicit (from @build-depends@). Not - -- mix-in linked yet; component configuration only looks at - -- 'ComponentId's. - cc_includes :: [ComponentInclude ComponentId IncludeRenaming] - } - +data ConfiguredComponent = ConfiguredComponent + { cc_ann_id :: AnnotatedId ComponentId + -- ^ Unique identifier of component, plus extra useful info. + , cc_component :: Component + -- ^ The fragment of syntax from the Cabal file describing this + -- component. + , cc_public :: Bool + -- ^ Is this the public library component of the package? + -- (If we invoke Setup with an instantiation, this is the + -- component the instantiation applies to.) + -- Note that in one-component configure mode, this is + -- always True, because any component is the "public" one.) + , cc_exe_deps :: [AnnotatedId ComponentId] + -- ^ Dependencies on executables from @build-tools@ and + -- @build-tool-depends@. + , cc_includes :: [ComponentInclude ComponentId IncludeRenaming] + -- ^ The mixins of this package, including both explicit (from + -- the @mixins@ field) and implicit (from @build-depends@). Not + -- mix-in linked yet; component configuration only looks at + -- 'ComponentId's. + } -- | Uniquely identifies a configured component. cc_cid :: ConfiguredComponent -> ComponentId @@ -93,110 +79,132 @@ -- | Pretty-print a 'ConfiguredComponent'. dispConfiguredComponent :: ConfiguredComponent -> Doc dispConfiguredComponent cc = - hang (text "component" <+> pretty (cc_cid cc)) 4 - (vcat [ hsep $ [ text "include" - , pretty (ci_id incl), pretty (ci_renaming incl) ] - | incl <- cc_includes cc - ]) + hang + (text "component" <+> pretty (cc_cid cc)) + 4 + ( vcat + [ hsep $ + [ text "include" + , pretty (ci_id incl) + , pretty (ci_renaming incl) + ] + | incl <- cc_includes cc + ] + ) -- | Construct a 'ConfiguredComponent', given that the 'ComponentId' -- and library/executable dependencies are known. The primary -- work this does is handling implicit @backpack-include@ fields. mkConfiguredComponent - :: PackageDescription - -> ComponentId - -> [AnnotatedId ComponentId] -- lib deps - -> [AnnotatedId ComponentId] -- exe deps - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> [AnnotatedId ComponentId] -- lib deps + -> [AnnotatedId ComponentId] -- exe deps + -> Component + -> LogProgress ConfiguredComponent mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do - -- Resolve each @mixins@ into the actual dependency - -- from @lib_deps@. - explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do - aid <- case Map.lookup (pn, CLibName ln) deps_map of - Nothing -> - dieProgress $ - text "Mix-in refers to non-existent library" <+> - quotes (pretty pn <<>> prettyLN ln) $$ - text "(did you forget to add the package to build-depends?)" - Just r -> return r - return ComponentInclude { - ci_ann_id = aid, - ci_renaming = rns, - ci_implicit = False - } + -- Resolve each @mixins@ into the actual dependency + -- from @lib_deps@. + explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do + aid <- case Map.lookup (pn, CLibName ln) deps_map of + Nothing -> + dieProgress $ + text "Mix-in refers to non-existent library" + <+> quotes (pretty pn <<>> prettyLN ln) + $$ text "(did you forget to add the package to build-depends?)" + Just r -> return r + return + ComponentInclude + { ci_ann_id = aid + , ci_renaming = rns + , ci_implicit = False + } - -- Any @build-depends@ which is not explicitly mentioned in - -- @backpack-include@ is converted into an "implicit" include. - let used_explicitly = Set.fromList (map ci_id explicit_includes) - implicit_includes - = map (\aid -> ComponentInclude { - ci_ann_id = aid, - ci_renaming = defaultIncludeRenaming, - ci_implicit = True - }) - $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps + -- Any @build-depends@ which is not explicitly mentioned in + -- @backpack-include@ is converted into an "implicit" include. + let used_explicitly = Set.fromList (map ci_id explicit_includes) + implicit_includes = + map + ( \aid -> + ComponentInclude + { ci_ann_id = aid + , ci_renaming = defaultIncludeRenaming + , ci_implicit = True + } + ) + $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps - return ConfiguredComponent { - cc_ann_id = AnnotatedId { - ann_id = this_cid, - ann_pid = package pkg_descr, - ann_cname = componentName component - }, - cc_component = component, - cc_public = is_public, - cc_exe_deps = exe_deps, - cc_includes = explicit_includes ++ implicit_includes - } + return + ConfiguredComponent + { cc_ann_id = + AnnotatedId + { ann_id = this_cid + , ann_pid = package pkg_descr + , ann_cname = componentName component + } + , cc_component = component + , cc_public = is_public + , cc_exe_deps = exe_deps + , cc_includes = explicit_includes ++ implicit_includes + } where bi :: BuildInfo bi = componentBuildInfo component prettyLN :: LibraryName -> Doc - prettyLN LMainLibName = PP.empty + prettyLN LMainLibName = PP.empty prettyLN (LSubLibName n) = PP.colon <<>> pretty n deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId) - deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep) - | dep <- lib_deps ] + deps_map = + Map.fromList + [ ((packageName dep, ann_cname dep), dep) + | dep <- lib_deps + ] is_public = componentName component == CLibName LMainLibName type ConfiguredComponentMap = - Map PackageName (Map ComponentName (AnnotatedId ComponentId)) + Map PackageName (Map ComponentName (AnnotatedId ComponentId)) toConfiguredComponent - :: PackageDescription - -> ComponentId - -> ConfiguredComponentMap - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent + :: PackageDescription + -> ComponentId + -> ConfiguredComponentMap + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do - lib_deps <- - if newPackageDepsBehaviour pkg_descr - then fmap concat $ forM (targetBuildDepends bi) $ - \(Dependency name _ sublibs) -> do - pkg <- case Map.lookup name lib_dep_map of + lib_deps <- + if newPackageDepsBehaviour pkg_descr + then fmap concat $ + forM (targetBuildDepends bi) $ + \(Dependency name _ sublibs) -> do + case Map.lookup name lib_dep_map of + Nothing -> + dieProgress $ + text "Dependency on unbuildable" + <+> text "package" + <+> pretty name + Just pkg -> do + -- Return all library components + forM (NonEmptySet.toList sublibs) $ \lib -> + let comp = CLibName lib + in case Map.lookup comp pkg of Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text "package" <+> pretty name - Just p -> return p - -- Return all library components - forM (NonEmptySet.toList sublibs) $ \lib -> - let comp = CLibName lib in - case Map.lookup comp pkg of - Nothing -> - dieProgress $ - text "Dependency on unbuildable" <+> - text (showLibraryName lib) <+> - text "from" <+> pretty name - Just v -> return v - else return old_style_lib_deps - mkConfiguredComponent - pkg_descr this_cid - lib_deps exe_deps component + dieProgress $ + text "Dependency on unbuildable" + <+> text (showLibraryName lib) + <+> text "from" + <+> pretty name + Just v -> return v + else return old_style_lib_deps + mkConfiguredComponent + pkg_descr + this_cid + lib_deps + exe_deps + component where bi = componentBuildInfo component -- lib_dep_map contains a mix of internal and external deps. @@ -206,62 +214,84 @@ -- this is not supported by old-style deps behavior -- because it would imply a cyclic dependency for the -- library itself. - old_style_lib_deps = [ e - | (pn, comp_map) <- Map.toList lib_dep_map - , pn /= packageName pkg_descr - , (cn, e) <- Map.toList comp_map - , cn == CLibName LMainLibName ] + old_style_lib_deps = + [ e + | (pn, comp_map) <- Map.toList lib_dep_map + , pn /= packageName pkg_descr + , (cn, e) <- Map.toList comp_map + , cn == CLibName LMainLibName + ] -- We have to nub here, because 'getAllToolDependencies' may return -- duplicates (see #4986). (NB: This is not needed for lib_deps, -- since those elaborate into includes, for which there explicitly -- may be multiple instances of a package) - exe_deps = ordNub $ + exe_deps = + ordNub $ [ exe | ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi - -- The error suppression here is important, because in general + , -- The error suppression here is important, because in general -- we won't know about external dependencies (e.g., 'happy') -- which the package is attempting to use (those deps are only -- fed in when cabal-install uses this codepath.) -- TODO: Let cabal-install request errors here - , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] + Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map] ] -- | Also computes the 'ComponentId', and sets cc_public if necessary. -- This is Cabal-only; cabal-install won't use this. toConfiguredComponent' - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> PackageDescription - -> Bool -- deterministic - -> Flag String -- configIPID (todo: remove me) - -> Flag ComponentId -- configCID - -> ConfiguredComponentMap - -> Component - -> LogProgress ConfiguredComponent -toConfiguredComponent' use_external_internal_deps flags - pkg_descr deterministic ipid_flag cid_flag - dep_map component = do - cc <- toConfiguredComponent - pkg_descr this_cid - dep_map dep_map component - return $ if use_external_internal_deps - then cc { cc_public = True } - else cc - where - -- TODO: pass component names to it too! - this_cid = computeComponentId deterministic ipid_flag cid_flag - (package pkg_descr) (componentName component) (Just (deps, flags)) - deps = [ ann_id aid | m <- Map.elems dep_map - , aid <- Map.elems m ] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> PackageDescription + -> Bool -- deterministic + -> Flag String -- configIPID (todo: remove me) + -> Flag ComponentId -- configCID + -> ConfiguredComponentMap + -> Component + -> LogProgress ConfiguredComponent +toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + dep_map + component = do + cc <- + toConfiguredComponent + pkg_descr + this_cid + dep_map + dep_map + component + return $ + if use_external_internal_deps + then cc{cc_public = True} + else cc + where + -- TODO: pass component names to it too! + this_cid = + computeComponentId + deterministic + ipid_flag + cid_flag + (package pkg_descr) + (componentName component) + (Just (deps, flags)) + deps = + [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m + ] extendConfiguredComponentMap - :: ConfiguredComponent - -> ConfiguredComponentMap - -> ConfiguredComponentMap + :: ConfiguredComponent + -> ConfiguredComponentMap + -> ConfiguredComponentMap extendConfiguredComponentMap cc = - Map.insertWith Map.union - (pkgName (cc_pkgid cc)) - (Map.singleton (cc_name cc) (cc_ann_id cc)) + Map.insertWith + Map.union + (pkgName (cc_pkgid cc)) + (Map.singleton (cc_name cc) (cc_ann_id cc)) -- Compute the 'ComponentId's for a graph of 'Component's. The -- list of internal components must be topologically sorted @@ -273,31 +303,42 @@ -- be used to configure a component that depends on one version of a package for -- a library and another version for a build-tool. toConfiguredComponents - :: Bool -- use_external_internal_deps - -> FlagAssignment - -> Bool -- deterministic - -> Flag String -- configIPID - -> Flag ComponentId -- configCID - -> PackageDescription - -> ConfiguredComponentMap - -> [Component] - -> LogProgress [ConfiguredComponent] + :: Bool -- use_external_internal_deps + -> FlagAssignment + -> Bool -- deterministic + -> Flag String -- configIPID + -> Flag ComponentId -- configCID + -> PackageDescription + -> ConfiguredComponentMap + -> [Component] + -> LogProgress [ConfiguredComponent] toConfiguredComponents - use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr - dep_map comps - = fmap snd (mapAccumM go dep_map comps) - where - go m component = do - cc <- toConfiguredComponent' - use_external_internal_deps flags pkg_descr - deterministic ipid_flag cid_flag - m component + use_external_internal_deps + flags + deterministic + ipid_flag + cid_flag + pkg_descr + dep_map + comps = + fmap snd (mapAccumM go dep_map comps) + where + go m component = do + cc <- + toConfiguredComponent' + use_external_internal_deps + flags + pkg_descr + deterministic + ipid_flag + cid_flag + m + component return (extendConfiguredComponentMap cc m, cc) newPackageDepsBehaviourMinVersion :: CabalSpecVersion newPackageDepsBehaviourMinVersion = CabalSpecV1_8 - -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per -- target, but we only enable this behaviour if the minimum cabal version @@ -305,4 +346,4 @@ -- old behaviour. newPackageDepsBehaviour :: PackageDescription -> Bool newPackageDepsBehaviour pkg = - specVersion pkg >= newPackageDepsBehaviourMinVersion + specVersion pkg >= newPackageDepsBehaviourMinVersion diff --git a/src/Distribution/Backpack/DescribeUnitId.hs b/src/Distribution/Backpack/DescribeUnitId.hs --- a/src/Distribution/Backpack/DescribeUnitId.hs +++ b/src/Distribution/Backpack/DescribeUnitId.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} + module Distribution.Backpack.DescribeUnitId where import Distribution.Compat.Prelude @@ -36,26 +37,36 @@ -- | Print a Setup message stating (1) what operation we are doing, -- for (2) which component (with enough details to uniquely identify -- the build in question.) --- -setupMessage' :: Pretty a => Verbosity - -> String -- ^ Operation being done (capitalized), on: - -> PackageIdentifier -- ^ Package - -> ComponentName -- ^ Component name - -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available. - -- Polymorphic to take - -- 'OpenModule' or 'Module' - -> IO () +setupMessage' + :: Pretty a + => Verbosity + -> String + -- ^ Operation being done (capitalized), on: + -> PackageIdentifier + -- ^ Package + -> ComponentName + -- ^ Component name + -> Maybe [(ModuleName, a)] + -- ^ Instantiation, if available. + -- Polymorphic to take + -- 'OpenModule' or 'Module' + -> IO () setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do - noticeDoc verbosity $ - case mb_insts of - Just insts | not (null insts) -> - hang (msg_doc <+> text "instantiated with") 2 - (vcat [ pretty k <+> text "=" <+> pretty v - | (k,v) <- insts ]) $$ - for_doc - _ -> - msg_doc <+> for_doc - + noticeDoc verbosity $ + case mb_insts of + Just insts + | not (null insts) -> + hang + (msg_doc <+> text "instantiated with") + 2 + ( vcat + [ pretty k <+> text "=" <+> pretty v + | (k, v) <- insts + ] + ) + $$ for_doc + _ -> + msg_doc <+> for_doc where msg_doc = text msg <+> text (showComponentName cname) - for_doc = text "for" <+> pretty pkgid <<>> text ".." + for_doc = text "for" <+> pretty pkgid <<>> text "..." diff --git a/src/Distribution/Backpack/FullUnitId.hs b/src/Distribution/Backpack/FullUnitId.hs --- a/src/Distribution/Backpack/FullUnitId.hs +++ b/src/Distribution/Backpack/FullUnitId.hs @@ -1,26 +1,27 @@ {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.FullUnitId ( - FullUnitId(..), - FullDb, - expandOpenUnitId, - expandUnitId -) where +module Distribution.Backpack.FullUnitId + ( FullUnitId (..) + , FullDb + , expandOpenUnitId + , expandUnitId + ) where + import Distribution.Backpack -import Distribution.Types.ComponentId import Distribution.Compat.Prelude +import Distribution.Types.ComponentId -- Unlike OpenUnitId, which could direct to a UnitId. data FullUnitId = FullUnitId ComponentId OpenModuleSubst - deriving (Show, Generic) + deriving (Show, Generic) type FullDb = DefUnitId -> FullUnitId expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId -expandOpenUnitId _db (IndefFullUnitId cid subst) - = FullUnitId cid subst -expandOpenUnitId db (DefiniteUnitId uid) - = expandUnitId db uid +expandOpenUnitId _db (IndefFullUnitId cid subst) = + FullUnitId cid subst +expandOpenUnitId db (DefiniteUnitId uid) = + expandUnitId db uid expandUnitId :: FullDb -> DefUnitId -> FullUnitId expandUnitId db uid = db uid diff --git a/src/Distribution/Backpack/Id.hs b/src/Distribution/Backpack/Id.hs --- a/src/Distribution/Backpack/Id.hs +++ b/src/Distribution/Backpack/Id.hs @@ -1,74 +1,87 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + -- | See -module Distribution.Backpack.Id( - computeComponentId, - computeCompatPackageKey, -) where +module Distribution.Backpack.Id + ( computeComponentId + , computeCompatPackageKey + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Simple.Compiler import Distribution.PackageDescription -import Distribution.Simple.Setup as Setup +import Distribution.Simple.Compiler +import Distribution.Simple.Flag (Flag, pattern Flag, pattern NoFlag) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.LocalBuildInfo import Distribution.Types.ComponentId -import Distribution.Types.UnitId import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import Distribution.Utils.Base62 import Distribution.Version +import Distribution.Parsec (simpleParsec) import Distribution.Pretty - ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) + ( prettyShow + ) -- | This method computes a default, "good enough" 'ComponentId' -- for a package. The intent is that cabal-install (or the user) will -- specify a more detailed IPID via the @--ipid@ flag if necessary. computeComponentId - :: Bool -- deterministic mode - -> Flag String - -> Flag ComponentId - -> PackageIdentifier - -> ComponentName - -- This is used by cabal-install's legacy codepath - -> Maybe ([ComponentId], FlagAssignment) - -> ComponentId + :: Bool -- deterministic mode + -> Flag String + -> Flag ComponentId + -> PackageIdentifier + -> ComponentName + -- This is used by cabal-install's legacy codepath + -> Maybe ([ComponentId], FlagAssignment) + -> ComponentId computeComponentId deterministic mb_ipid mb_cid pid cname mb_details = - -- show is found to be faster than intercalate and then replacement of - -- special character used in intercalating. We cannot simply hash by - -- doubly concating list, as it just flatten out the nested list, so - -- different sources can produce same hash - let hash_suffix - | Just (dep_ipids, flags) <- mb_details - = "-" ++ hashToBase62 + -- show is found to be faster than intercalate and then replacement of + -- special character used in intercalating. We cannot simply hash by + -- doubly concatenating list, as it just flatten out the nested list, so + -- different sources can produce same hash + let hash_suffix + | Just (dep_ipids, flags) <- mb_details = + "-" + ++ hashToBase62 -- For safety, include the package + version here -- for GHC 7.10, where just the hash is used as -- the package key - ( prettyShow pid - ++ show dep_ipids - ++ show flags ) - | otherwise = "" - generated_base = prettyShow pid ++ hash_suffix - explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env - (toPathTemplate cid0)) - -- Hack to reuse install dirs machinery - -- NB: no real IPID available at this point - where env = packageTemplateEnv pid (mkUnitId "") - actual_base = case mb_ipid of - Flag ipid0 -> explicit_base ipid0 - NoFlag | deterministic -> prettyShow pid - | otherwise -> generated_base - in case mb_cid of - Flag cid -> cid - NoFlag -> mkComponentId $ actual_base - ++ (case componentNameString cname of - Nothing -> "" - Just s -> "-" ++ unUnqualComponentName s) + ( prettyShow pid + ++ show dep_ipids + ++ show flags + ) + | otherwise = "" + generated_base = prettyShow pid ++ hash_suffix + explicit_base cid0 = + fromPathTemplate + ( InstallDirs.substPathTemplate + env + (toPathTemplate cid0) + ) + where + -- Hack to reuse install dirs machinery + -- NB: no real IPID available at this point + env = packageTemplateEnv pid (mkUnitId "") + actual_base = case mb_ipid of + Flag ipid0 -> explicit_base ipid0 + NoFlag + | deterministic -> prettyShow pid + | otherwise -> generated_base + in case mb_cid of + Flag cid -> cid + NoFlag -> + mkComponentId $ + actual_base + ++ ( case componentNameString cname of + Nothing -> "" + Just s -> "-" ++ unUnqualComponentName s + ) -- | In GHC 8.0, the string we pass to GHC to use for symbol -- names for a package can be an arbitrary, IPID-compatible string. @@ -116,30 +129,29 @@ -- -- * For sub-components, we rehash the IPID into the correct format -- and pass that. --- computeCompatPackageKey - :: Compiler - -> MungedPackageName - -> Version - -> UnitId - -> String + :: Compiler + -> MungedPackageName + -> Version + -> UnitId + -> String computeCompatPackageKey comp pkg_name pkg_version uid - | not (packageKeySupported comp || unitIdSupported comp) - = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version - | not (unifiedIPIDRequired comp) = - let str = unUnitId uid -- assume no Backpack support - mb_verbatim_key - = case simpleParsec str :: Maybe PackageId of - -- Something like 'foo-0.1', use it verbatim. - -- (NB: hash tags look like tags, so they are parsed, - -- so the extra equality check tests if a tag was dropped.) - Just pid0 | prettyShow pid0 == str -> Just str - _ -> Nothing - mb_truncated_key - = let cand = reverse (takeWhile isAlphaNum (reverse str)) - in if length cand == 22 && all isAlphaNum cand - then Just cand - else Nothing - rehashed_key = hashToBase62 str - in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) - | otherwise = prettyShow uid + | not (packageKeySupported comp || unitIdSupported comp) = + prettyShow pkg_name ++ "-" ++ prettyShow pkg_version + | not (unifiedIPIDRequired comp) = + let str = unUnitId uid -- assume no Backpack support + mb_verbatim_key = + case simpleParsec str :: Maybe PackageId of + -- Something like 'foo-0.1', use it verbatim. + -- (NB: hash tags look like tags, so they are parsed, + -- so the extra equality check tests if a tag was dropped.) + Just pid0 | prettyShow pid0 == str -> Just str + _ -> Nothing + mb_truncated_key = + let cand = reverse (takeWhile isAlphaNum (reverse str)) + in if length cand == 22 && all isAlphaNum cand + then Just cand + else Nothing + rehashed_key = hashToBase62 str + in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key) + | otherwise = prettyShow uid diff --git a/src/Distribution/Backpack/LinkedComponent.hs b/src/Distribution/Backpack/LinkedComponent.hs --- a/src/Distribution/Backpack/LinkedComponent.hs +++ b/src/Distribution/Backpack/LinkedComponent.hs @@ -1,82 +1,76 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.LinkedComponent ( - LinkedComponent(..), - lc_insts, - lc_uid, - lc_cid, - lc_pkgid, - toLinkedComponent, - toLinkedComponents, - dispLinkedComponent, - LinkedComponentMap, - extendLinkedComponentMap, -) where +module Distribution.Backpack.LinkedComponent + ( LinkedComponent (..) + , lc_insts + , lc_uid + , lc_cid + , lc_pkgid + , toLinkedComponent + , toLinkedComponents + , dispLinkedComponent + , LinkedComponentMap + , extendLinkedComponentMap + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.FullUnitId import Distribution.Backpack.ConfiguredComponent +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.MixLink +import Distribution.Backpack.ModuleScope import Distribution.Backpack.ModuleShape import Distribution.Backpack.PreModuleShape -import Distribution.Backpack.ModuleScope import Distribution.Backpack.UnifyM -import Distribution.Backpack.MixLink import Distribution.Utils.MapAccum -import Distribution.Types.AnnotatedId -import Distribution.Types.ComponentName -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.IncludeRenaming -import Distribution.Types.ComponentInclude -import Distribution.Types.ComponentId -import Distribution.Types.PackageId +import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription -import Distribution.ModuleName import Distribution.Simple.LocalBuildInfo -import Distribution.Verbosity +import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude import Distribution.Utils.LogProgress +import Distribution.Verbosity -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Pretty (pretty) -import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes) +import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$)) -- | A linked component is a component that has been mix-in linked, at -- which point we have determined how all the dependencies of the -- component are explicitly instantiated (in the form of an OpenUnitId). -- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which -- is then instantiated into 'ReadyComponent'. -data LinkedComponent - = LinkedComponent { - -- | Uniquely identifies linked component - lc_ann_id :: AnnotatedId ComponentId, - -- | Corresponds to 'cc_component'. - lc_component :: Component, - -- | @build-tools@ and @build-tool-depends@ dependencies. - -- Corresponds to 'cc_exe_deps'. - lc_exe_deps :: [AnnotatedId OpenUnitId], - -- | Is this the public library of a package? Corresponds to - -- 'cc_public'. - lc_public :: Bool, - -- | Corresponds to 'cc_includes', but (1) this does not contain - -- includes of signature packages (packages with no exports), - -- and (2) the 'ModuleRenaming' for requirements (stored in - -- 'IncludeRenaming') has been removed, as it is reflected in - -- 'OpenUnitId'.) - lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | Like 'lc_includes', but this specifies includes on - -- signature packages which have no exports. - lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming], - -- | The module shape computed by mix-in linking. This is - -- newly computed from 'ConfiguredComponent' - lc_shape :: ModuleShape - } +data LinkedComponent = LinkedComponent + { lc_ann_id :: AnnotatedId ComponentId + -- ^ Uniquely identifies linked component + , lc_component :: Component + -- ^ Corresponds to 'cc_component'. + , lc_exe_deps :: [AnnotatedId OpenUnitId] + -- ^ @build-tools@ and @build-tool-depends@ dependencies. + -- Corresponds to 'cc_exe_deps'. + , lc_public :: Bool + -- ^ Is this the public library of a package? Corresponds to + -- 'cc_public'. + , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Corresponds to 'cc_includes', but (1) this does not contain + -- includes of signature packages (packages with no exports), + -- and (2) the 'ModuleRenaming' for requirements (stored in + -- 'IncludeRenaming') has been removed, as it is reflected in + -- 'OpenUnitId'.) + , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ Like 'lc_includes', but this specifies includes on + -- signature packages which have no exports. + , lc_shape :: ModuleShape + -- ^ The module shape computed by mix-in linking. This is + -- newly computed from 'ConfiguredComponent' + } -- | Uniquely identifies a 'LinkedComponent'. Corresponds to -- 'cc_cid'. @@ -96,94 +90,125 @@ -- | The instantiation of 'lc_uid'; this always has the invariant -- that it is a mapping from a module name @A@ to @@ (the hole A). lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)] -lc_insts lc = [ (req, OpenModuleVar req) - | req <- Set.toList (modShapeRequires (lc_shape lc)) ] +lc_insts lc = + [ (req, OpenModuleVar req) + | req <- Set.toList (modShapeRequires (lc_shape lc)) + ] dispLinkedComponent :: LinkedComponent -> Doc dispLinkedComponent lc = - hang (text "unit" <+> pretty (lc_uid lc)) 4 $ - vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) - | incl <- lc_includes lc ] - $+$ - vcat [ text "signature include" <+> pretty (ci_id incl) - | incl <- lc_sig_includes lc ] - $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) + hang (text "unit" <+> pretty (lc_uid lc)) 4 $ + vcat + [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl) + | incl <- lc_includes lc + ] + $+$ vcat + [ text "signature include" <+> pretty (ci_id incl) + | incl <- lc_sig_includes lc + ] + $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc)) instance Package LinkedComponent where - packageId = lc_pkgid + packageId = lc_pkgid toLinkedComponent - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> ConfiguredComponent - -> LogProgress LinkedComponent -toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent { - cc_ann_id = aid@AnnotatedId { ann_id = this_cid }, - cc_component = component, - cc_exe_deps = exe_deps, - cc_public = is_public, - cc_includes = cid_includes - } = do + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> ConfiguredComponent + -> LogProgress LinkedComponent +toLinkedComponent + verbosity + anyPromised + db + this_pid + pkg_map + ConfiguredComponent + { cc_ann_id = aid@AnnotatedId{ann_id = this_cid} + , cc_component = component + , cc_exe_deps = exe_deps + , cc_public = is_public + , cc_includes = cid_includes + } = do let - -- The explicitly specified requirements, provisions and - -- reexports from the Cabal file. These are only non-empty for - -- libraries; everything else is trivial. - (src_reqs :: [ModuleName], - src_provs :: [ModuleName], - src_reexports :: [ModuleReexport]) = - case component of - CLib lib -> (signatures lib, - exposedModules lib, - reexportedModules lib) - _ -> ([], [], []) - src_hidden = otherModules (componentBuildInfo component) + -- The explicitly specified requirements, provisions and + -- reexports from the Cabal file. These are only non-empty for + -- libraries; everything else is trivial. + ( src_reqs :: [ModuleName] + , src_provs :: [ModuleName] + , src_reexports :: [ModuleReexport] + ) = + case component of + CLib lib -> + ( signatures lib + , exposedModules lib + , reexportedModules lib + ) + _ -> ([], [], []) + src_hidden = otherModules (componentBuildInfo component) - -- Take each included ComponentId and resolve it into an - -- *unlinked* unit identity. We will use unification (relying - -- on the ModuleShape) to resolve these into linked identities. - unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] - unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i - | ComponentInclude dep_aid rns i <- cid_includes ] + -- Take each included ComponentId and resolve it into an + -- \*unlinked* unit identity. We will use unification (relying + -- on the ModuleShape) to resolve these into linked identities. + unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming] + unlinked_includes = + [ ComponentInclude (fmap lookupUid dep_aid) rns i + | ComponentInclude dep_aid rns i <- cid_includes + ] - lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) - lookupUid cid = fromMaybe (error "linkComponent: lookupUid") - (Map.lookup cid pkg_map) + lookupUid :: ComponentId -> (OpenUnitId, ModuleShape) + lookupUid cid = + fromMaybe + (error "linkComponent: lookupUid") + (Map.lookup cid pkg_map) let orErr (Right x) = return x orErr (Left [err]) = dieProgress err orErr (Left errs) = do - dieProgress (vcat (intersperse (text "") -- double newline! - [ hang (text "-") 2 err | err <- errs])) + dieProgress + ( vcat + ( intersperse + (text "") -- double newline! + [hang (text "-") 2 err | err <- errs] + ) + ) -- Pre-shaping - let pre_shape = mixLinkPreModuleShape $ - PreModuleShape { - preModShapeProvides = Set.fromList (src_provs ++ src_hidden), - preModShapeRequires = Set.fromList src_reqs - } : [ renamePreModuleShape (toPreModuleShape sh) rns - | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ] - reqs = preModShapeRequires pre_shape - insts = [ (req, OpenModuleVar req) - | req <- Set.toList reqs ] + let pre_shape = + mixLinkPreModuleShape $ + PreModuleShape + { preModShapeProvides = Set.fromList (src_provs ++ src_hidden) + , preModShapeRequires = Set.fromList src_reqs + } + : [ renamePreModuleShape (toPreModuleShape sh) rns + | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes + ] + reqs = preModShapeRequires pre_shape + insts = + [ (req, OpenModuleVar req) + | req <- Set.toList reqs + ] this_uid = IndefFullUnitId this_cid . Map.fromList $ insts -- OK, actually do unification -- TODO: the unification monad might return errors, in which -- case we have to deal. Use monadic bind for now. - (linked_shape0 :: ModuleScope, - linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming], - linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]) - <- orErr $ runUnifyM verbosity this_cid db $ do + ( linked_shape0 :: ModuleScope + , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming] + ) <- + orErr $ runUnifyM verbosity this_cid db $ do -- The unification monad is implemented using mutable -- references. Thus, we must convert our *pure* data -- structures into mutable ones to perform unification. let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s) convertMod from m = do - m_u <- convertModule (OpenModule this_uid m) - return (Map.singleton m [WithSource (from m) m_u], Map.empty) + m_u <- convertModule (OpenModule this_uid m) + return (Map.singleton m [WithSource (from m) m_u], Map.empty) -- Handle 'exposed-modules' exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs -- Handle 'other-modules' @@ -192,8 +217,8 @@ -- Handle 'signatures' let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s) convertReq req = do - req_u <- convertModule (OpenModuleVar req) - return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) + req_u <- convertModule (OpenModuleVar req) + return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u]) req_shapes_u <- traverse convertReq src_reqs -- Handle 'mixins' @@ -201,21 +226,27 @@ failIfErrs -- Prevent error cascade -- Mix-in link everything! mixLink is the real workhorse. - shape_u <- mixLink $ exposed_mod_shapes_u - ++ other_mod_shapes_u - ++ req_shapes_u - ++ incl_shapes_u + shape_u <- + mixLink $ + exposed_mod_shapes_u + ++ other_mod_shapes_u + ++ req_shapes_u + ++ incl_shapes_u -- src_reqs_u <- traverse convertReq src_reqs -- Read out all the final results by converting back -- into a pure representation. let convertIncludeU (ComponentInclude dep_aid rns i) = do - uid <- convertUnitIdU (ann_id dep_aid) - return (ComponentInclude { - ci_ann_id = dep_aid { ann_id = uid }, - ci_renaming = rns, - ci_implicit = i - }) + let component_name = pretty $ ann_cname dep_aid + uid <- convertUnitIdU (ann_id dep_aid) component_name + return + ( ComponentInclude + { ci_ann_id = dep_aid{ann_id = uid} + , ci_renaming = rns + , ci_implicit = i + } + ) + shape <- convertModuleScopeU shape_u let (includes_u, sig_includes_u) = partitionEithers all_includes_u incls <- traverse convertIncludeU includes_u @@ -223,23 +254,26 @@ return (shape, incls, sig_incls) let isNotLib (CLib _) = False - isNotLib _ = True + isNotLib _ = True when (not (Set.null reqs) && isNotLib component) $ - dieProgress $ - hang (text "Non-library component has unfilled requirements:") - 4 (vcat [pretty req | req <- Set.toList reqs]) + dieProgress $ + hang + (text "Non-library component has unfilled requirements:") + 4 + (vcat [pretty req | req <- Set.toList reqs]) -- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg -- won't allow it (since someone could directly synthesize -- an 'InstalledPackageInfo' that violates abstraction.) -- Though, maybe it should be relaxed? let src_hidden_set = Set.fromList src_hidden - linked_shape = linked_shape0 { - modScopeProvides = + linked_shape = + linked_shape0 + { modScopeProvides = -- Would rather use withoutKeys but need BC Map.filterWithKey - (\k _ -> not (k `Set.member` src_hidden_set)) - (modScopeProvides linked_shape0) + (\k _ -> not (k `Set.member` src_hidden_set)) + (modScopeProvides linked_shape0) } -- OK, compute the reexports @@ -248,65 +282,102 @@ -- once. let hdl :: [Either Doc a] -> LogProgress [a] hdl es = - case partitionEithers es of - ([], rs) -> return rs - (ls, _) -> - dieProgress $ - hang (text "Problem with module re-exports:") 2 - (vcat [hang (text "-") 2 l | l <- ls]) + case partitionEithers es of + ([], rs) -> return rs + (ls, _) -> + dieProgress $ + hang + (text "Problem with module re-exports:") + 2 + (vcat [hang (text "-") 2 l | l <- ls]) reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do case Map.lookup from (modScopeProvides linked_shape) of - Just cands@(x0:xs0) -> do + Just cands@(x0 : xs0) -> do -- Make sure there is at least one candidate (x, xs) <- case mb_pn of Just pn -> - let matches_pn (FromMixins pn' _ _) = pn == pn' + let matches_pn (FromMixins pn' _ _) = pn == pn' matches_pn (FromBuildDepends pn' _) = pn == pn' matches_pn (FromExposedModules _) = pn == packageName this_pid - matches_pn (FromOtherModules _) = pn == packageName this_pid - matches_pn (FromSignatures _) = pn == packageName this_pid - in case filter (matches_pn . getSource) cands of - (x1:xs1) -> return (x1, xs1) - _ -> Left (brokenReexportMsg reex) + matches_pn (FromOtherModules _) = pn == packageName this_pid + matches_pn (FromSignatures _) = pn == packageName this_pid + in case filter (matches_pn . getSource) cands of + (x1 : xs1) -> return (x1, xs1) + _ -> Left (brokenReexportMsg reex) Nothing -> return (x0, xs0) -- Test that all the candidates are consistent case filter (\x' -> unWithSource x /= unWithSource x') xs of [] -> return () _ -> Left $ ambiguousReexportMsg reex x xs - return (to, unWithSource x) + return (to, Just (unWithSource x)) _ -> - Left (brokenReexportMsg reex) + -- Can't resolve it right now.. carry on with the assumption it will be resolved + -- dynamically later by an in-memory package which hasn't been installed yet. + if anyPromised + then return (to, Nothing) + else -- But if nothing is promised, eagerly report an error, as we already know everything. + Left (brokenReexportMsg reex) -- TODO: maybe check this earlier; it's syntactically obvious. let build_reexports m (k, v) - | Map.member k m = - dieProgress $ hsep - [ text "Module name ", pretty k, text " is exported multiple times." ] - | otherwise = return (Map.insert k v m) - provs <- foldM build_reexports Map.empty $ - -- TODO: doublecheck we have checked for - -- src_provs duplicates already! - [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++ - reexports_list + | Map.member k m = + dieProgress $ + hsep + [text "Module name ", pretty k, text " is exported multiple times."] + | otherwise = return (Map.insert k v m) + provs <- + foldM build_reexports Map.empty $ + -- TODO: doublecheck we have checked for + -- src_provs duplicates already! + -- These are normal module exports. + [(mod_name, (OpenModule this_uid mod_name)) | mod_name <- src_provs] + ++ + -- These are reexports, which we managed to resolve to something in an external package. + [(mn_new, om) | (mn_new, Just om) <- reexports_list] + ++ + -- These ones.. we didn't resolve but also we might not have to + -- resolve them because they could come from a promised unit, + -- which we don't know anything about yet. GHC will resolve + -- these itself when it is dealing with the multi-session. + -- These ones will not be built, registered and put + -- into a package database, we only need them to make it as far + -- as generating GHC options where the info will be used to + -- pass the reexported-module option to GHC. + -- We also know that in the case there are promised units that + -- we will not be doing anything to do with backpack like + -- unification etc.. + [ ( mod_name + , OpenModule + ( DefiniteUnitId + ( unsafeMkDefUnitId + (mkUnitId "fake") + ) + ) + mod_name + ) + | (mod_name, Nothing) <- reexports_list + ] + let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape)) -- See Note Note [Signature package special case] let (linked_includes, linked_sig_includes) - | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) - | otherwise = (linked_includes0, linked_sig_includes0) + | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, []) + | otherwise = (linked_includes0, linked_sig_includes0) - return $ LinkedComponent { - lc_ann_id = aid, - lc_component = component, - lc_public = is_public, - -- These must be executables - lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps, - lc_shape = final_linked_shape, - lc_includes = linked_includes, - lc_sig_includes = linked_sig_includes - } + return $ + LinkedComponent + { lc_ann_id = aid + , lc_component = component + , lc_public = is_public + , -- These must be executables + lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps + , lc_shape = final_linked_shape + , lc_includes = linked_includes + , lc_sig_includes = linked_sig_includes + } -- Note [Signature package special case] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -334,63 +405,82 @@ -- Handle mix-in linking for components. In the absence of Backpack, -- every ComponentId gets converted into a UnitId by way of SimpleUnitId. toLinkedComponents - :: Verbosity - -> FullDb - -> PackageId - -> LinkedComponentMap - -> [ConfiguredComponent] - -> LogProgress [LinkedComponent] -toLinkedComponents verbosity db this_pid lc_map0 comps - = fmap snd (mapAccumM go lc_map0 comps) - where - go :: Map ComponentId (OpenUnitId, ModuleShape) - -> ConfiguredComponent - -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) - go lc_map cc = do - lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ - toLinkedComponent verbosity db this_pid lc_map cc - return (extendLinkedComponentMap lc lc_map, lc) + :: Verbosity + -> Bool + -- ^ Whether there are any "promised" package dependencies which we won't + -- find already installed. + -> FullDb + -> PackageId + -> LinkedComponentMap + -> [ConfiguredComponent] + -> LogProgress [LinkedComponent] +toLinkedComponents verbosity anyPromised db this_pid lc_map0 comps = + fmap snd (mapAccumM go lc_map0 comps) + where + go + :: Map ComponentId (OpenUnitId, ModuleShape) + -> ConfiguredComponent + -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent) + go lc_map cc = do + lc <- + addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $ + toLinkedComponent verbosity anyPromised db this_pid lc_map cc + return (extendLinkedComponentMap lc lc_map, lc) type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape) -extendLinkedComponentMap :: LinkedComponent - -> LinkedComponentMap - -> LinkedComponentMap +extendLinkedComponentMap + :: LinkedComponent + -> LinkedComponentMap + -> LinkedComponentMap extendLinkedComponentMap lc m = - Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m + Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m brokenReexportMsg :: ModuleReexport -> Doc brokenReexportMsg (ModuleReexport (Just pn) from _to) = - vcat [ text "The package" <+> quotes (pretty pn) - , text "does not export a module" <+> quotes (pretty from) ] + vcat + [ text "The package" <+> quotes (pretty pn) + , text "does not export a module" <+> quotes (pretty from) + ] brokenReexportMsg (ModuleReexport Nothing from _to) = - vcat [ text "The module" <+> quotes (pretty from) - , text "is not exported by any suitable package." - , text "It occurs in neither the 'exposed-modules' of this package," - , text "nor any of its 'build-depends' dependencies." ] + vcat + [ text "The module" <+> quotes (pretty from) + , text "is not exported by any suitable package." + , text "It occurs in neither the 'exposed-modules' of this package," + , text "nor any of its 'build-depends' dependencies." + ] ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys = - vcat [ text "Ambiguous reexport" <+> quotes (pretty from) - , hang (text "It could refer to either:") 2 - (vcat (msg : msgs)) - , help_msg mb_pn ] + vcat + [ text "Ambiguous reexport" <+> quotes (pretty from) + , hang + (text "It could refer to either:") + 2 + (vcat (msg : msgs)) + , help_msg mb_pn + ] where - msg = text " " <+> displayModuleWithSource y1 + msg = text " " <+> displayModuleWithSource y1 msgs = [text "or" <+> displayModuleWithSource y | y <- ys] help_msg Nothing = -- TODO: This advice doesn't help if the ambiguous exports -- come from a package named the same thing - vcat [ text "The ambiguity can be resolved by qualifying the" - , text "re-export with a package name." - , text "The syntax is 'packagename:ModuleName [as NewName]'." ] + vcat + [ text "The ambiguity can be resolved by qualifying the" + , text "re-export with a package name." + , text "The syntax is 'packagename:ModuleName [as NewName]'." + ] -- Qualifying won't help that much. help_msg (Just _) = - vcat [ text "The ambiguity can be resolved by using the" - , text "mixins field to rename one of the module" - , text "names differently." ] - displayModuleWithSource y - = vcat [ quotes (pretty (unWithSource y)) - , text "brought into scope by" <+> - dispModuleSource (getSource y) - ] + vcat + [ text "The ambiguity can be resolved by using the" + , text "mixins field to rename one of the module" + , text "names differently." + ] + displayModuleWithSource y = + vcat + [ quotes (pretty (unWithSource y)) + , text "brought into scope by" + <+> dispModuleSource (getSource y) + ] diff --git a/src/Distribution/Backpack/MixLink.hs b/src/Distribution/Backpack/MixLink.hs --- a/src/Distribution/Backpack/MixLink.hs +++ b/src/Distribution/Backpack/MixLink.hs @@ -1,26 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | See -module Distribution.Backpack.MixLink ( - mixLink, -) where +module Distribution.Backpack.MixLink + ( mixLink + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack -import Distribution.Backpack.UnifyM import Distribution.Backpack.FullUnitId import Distribution.Backpack.ModuleScope +import Distribution.Backpack.UnifyM -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Pretty import Distribution.Types.ComponentId +import qualified Distribution.Utils.UnionFind as UnionFind -import Text.PrettyPrint import Control.Monad -import qualified Data.Map as Map import qualified Data.Foldable as F +import qualified Data.Map as Map +import Text.PrettyPrint ----------------------------------------------------------------------- -- Linking @@ -28,78 +29,98 @@ -- | Given to scopes of provisions and requirements, link them together. mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s) mixLink scopes = do - let provs = Map.unionsWith (++) (map fst scopes) - -- Invariant: any identically named holes refer to same mutable cell - reqs = Map.unionsWith (++) (map snd scopes) - filled = Map.intersectionWithKey linkProvision provs reqs - F.sequenceA_ filled - let remaining = Map.difference reqs filled - return (provs, remaining) + let provs = Map.unionsWith (++) (map fst scopes) + -- Invariant: any identically named holes refer to same mutable cell + reqs = Map.unionsWith (++) (map snd scopes) + filled = Map.intersectionWithKey linkProvision provs reqs + F.sequenceA_ filled + let remaining = Map.difference reqs filled + return (provs, remaining) -- | Link a list of possibly provided modules to a single -- requirement. This applies a side-condition that all -- of the provided modules at the same name are *actually* -- the same module. -linkProvision :: ModuleName - -> [ModuleWithSourceU s] -- provs - -> [ModuleWithSourceU s] -- reqs - -> UnifyM s [ModuleWithSourceU s] -linkProvision mod_name ret@(prov:provs) (req:reqs) = do - -- TODO: coalesce all the non-unifying modules together - forM_ provs $ \prov' -> do - -- Careful: read it out BEFORE unifying, because the - -- unification algorithm preemptively unifies modules - mod <- convertModuleU (unWithSource prov) - mod' <- convertModuleU (unWithSource prov') - r <- unify prov prov' - case r of - Just () -> return () - Nothing -> do - addErr $ - text "Ambiguous module" <+> quotes (pretty mod_name) $$ - text "It could refer to" <+> - ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$ - text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$ - link_doc +linkProvision + :: ModuleName + -> [ModuleWithSourceU s] -- provs + -> [ModuleWithSourceU s] -- reqs + -> UnifyM s [ModuleWithSourceU s] +linkProvision mod_name ret@(prov : provs) (req : reqs) = do + -- TODO: coalesce all the non-unifying modules together + forM_ provs $ \prov' -> do + -- Careful: read it out BEFORE unifying, because the + -- unification algorithm preemptively unifies modules mod <- convertModuleU (unWithSource prov) - req_mod <- convertModuleU (unWithSource req) - self_cid <- fmap unify_self_cid getUnifEnv - case mod of - OpenModule (IndefFullUnitId cid _) _ - | cid == self_cid -> addErr $ - text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+> - in_scope_by (getSource req) $$ - text "with locally defined module" <+> in_scope_by (getSource prov) $$ - text "as this would create a cyclic dependency, which GHC does not support." $$ - text "Try moving this module to a separate library, e.g.," $$ - text "create a new stanza: library 'sublib'." - _ -> return () - r <- unify prov req + mod' <- convertModuleU (unWithSource prov') + r <- unify prov prov' case r of - Just () -> return () - Nothing -> do - -- TODO: Record and report WHERE the bad constraint came from - addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$ - nest 4 (text "Expected:" <+> pretty mod $$ - text "Actual: " <+> pretty req_mod) $$ - parens (text "This can occur if an exposed module of" <+> - text "a libraries shares a name with another module.") $$ - link_doc - return ret + Just () -> return () + Nothing -> do + addErr $ + text "Ambiguous module" + <+> quotes (pretty mod_name) + $$ text "It could refer to" + <+> ( text " " + <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) + $$ text "or" + <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) + ) + $$ link_doc + mod <- convertModuleU (unWithSource prov) + req_mod <- convertModuleU (unWithSource req) + self_cid <- fmap unify_self_cid getUnifEnv + case mod of + OpenModule (IndefFullUnitId cid _) _ + | cid == self_cid -> + addErr $ + text "Cannot instantiate requirement" + <+> quotes (pretty mod_name) + <+> in_scope_by (getSource req) + $$ text "with locally defined module" + <+> in_scope_by (getSource prov) + $$ text "as this would create a cyclic dependency, which GHC does not support." + $$ text "Try moving this module to a separate library, e.g.," + $$ text "create a new stanza: library 'sublib'." + _ -> return () + r <- unify prov req + case r of + Just () -> return () + Nothing -> do + -- TODO: Record and report WHERE the bad constraint came from + addErr $ + text "Could not instantiate requirement" + <+> quotes (pretty mod_name) + $$ nest + 4 + ( text "Expected:" + <+> pretty mod + $$ text "Actual: " + <+> pretty req_mod + ) + $$ parens + ( text "This can occur if an exposed module of" + <+> text "a libraries shares a name with another module." + ) + $$ link_doc + return ret where - unify s1 s2 = tryM $ addErrContext short_link_doc - $ unifyModule (unWithSource s1) (unWithSource s2) + unify s1 s2 = + tryM $ + addErrContext short_link_doc $ + unifyModule (unWithSource s1) (unWithSource s2) in_scope_by s = text "brought into scope by" <+> dispModuleSource s short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name) link_doc = text "While filling requirements of" <+> reqs_doc reqs_doc | null reqs = dispModuleSource (getSource req) - | otherwise = ( text " " <+> dispModuleSource (getSource req) $$ - vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs]) + | otherwise = + ( text " " + <+> dispModuleSource (getSource req) + $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs] + ) linkProvision _ _ _ = error "linkProvision" - - ----------------------------------------------------------------------- -- The unification algorithm @@ -108,78 +129,93 @@ unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s () unifyUnitId uid1_u uid2_u - | uid1_u == uid2_u = return () - | otherwise = do - xuid1 <- liftST $ UnionFind.find uid1_u - xuid2 <- liftST $ UnionFind.find uid2_u - case (xuid1, xuid2) of - (UnitIdThunkU u1, UnitIdThunkU u2) - | u1 == u2 -> return () - | otherwise -> - failWith $ hang (text "Couldn't match unit IDs:") 4 - (text " " <+> pretty u1 $$ - text "and" <+> pretty u2) - (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) - -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u - (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) - -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u - (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) - -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + | uid1_u == uid2_u = return () + | otherwise = do + xuid1 <- liftST $ UnionFind.find uid1_u + xuid2 <- liftST $ UnionFind.find uid2_u + case (xuid1, xuid2) of + (UnitIdThunkU u1, UnitIdThunkU u2) + | u1 == u2 -> return () + | otherwise -> + failWith $ + hang + (text "Couldn't match unit IDs:") + 4 + ( text " " + <+> pretty u1 + $$ text "and" + <+> pretty u2 + ) + (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) -> + unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u + (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) -> + unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u + (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) -> + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyThunkWith :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> DefUnitId - -> UnitIdU s - -> UnifyM s () +unifyThunkWith + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> DefUnitId + -> UnitIdU s + -> UnifyM s () unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do - db <- fmap unify_db getUnifEnv - let FullUnitId cid2 insts2' = expandUnitId db uid2 - insts2 <- convertModuleSubst insts2' - unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u + db <- fmap unify_db getUnifEnv + let FullUnitId cid2 insts2' = expandUnitId db uid2 + insts2 <- convertModuleSubst insts2' + unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u -unifyInner :: ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> ComponentId - -> Map ModuleName (ModuleU s) - -> UnitIdU s - -> UnifyM s () +unifyInner + :: ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> ComponentId + -> Map ModuleName (ModuleU s) + -> UnitIdU s + -> UnifyM s () unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do - when (cid1 /= cid2) $ - -- TODO: if we had a package identifier, could be an - -- easier to understand error message. - failWith $ - hang (text "Couldn't match component IDs:") 4 - (text " " <+> pretty cid1 $$ - text "and" <+> pretty cid2) - -- The KEY STEP which makes this a Huet-style unification - -- algorithm. (Also a payoff of using union-find.) - -- We can build infinite unit IDs this way, which is necessary - -- for support mutual recursion. NB: union keeps the SECOND - -- descriptor, so we always arrange for a UnitIdThunkU to live - -- there. - liftST $ UnionFind.union uid1_u uid2_u - F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 + when (cid1 /= cid2) $ + -- TODO: if we had a package identifier, could be an + -- easier to understand error message. + failWith $ + hang + (text "Couldn't match component IDs:") + 4 + ( text " " + <+> pretty cid1 + $$ text "and" + <+> pretty cid2 + ) + -- The KEY STEP which makes this a Huet-style unification + -- algorithm. (Also a payoff of using union-find.) + -- We can build infinite unit IDs this way, which is necessary + -- for support mutual recursion. NB: union keeps the SECOND + -- descriptor, so we always arrange for a UnitIdThunkU to live + -- there. + liftST $ UnionFind.union uid1_u uid2_u + F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2 -- | Imperatively unify two modules. unifyModule :: ModuleU s -> ModuleU s -> UnifyM s () unifyModule mod1_u mod2_u - | mod1_u == mod2_u = return () - | otherwise = do - mod1 <- liftST $ UnionFind.find mod1_u - mod2 <- liftST $ UnionFind.find mod2_u - case (mod1, mod2) of - (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u - (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u - (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do - when (mod_name1 /= mod_name2) $ - failWith $ - hang (text "Cannot match module names") 4 $ - text " " <+> pretty mod_name1 $$ - text "and" <+> pretty mod_name2 - -- NB: this is not actually necessary (because we'll - -- detect loops eventually in 'unifyUnitId'), but it - -- seems harmless enough - liftST $ UnionFind.union mod1_u mod2_u - unifyUnitId uid1 uid2 + | mod1_u == mod2_u = return () + | otherwise = do + mod1 <- liftST $ UnionFind.find mod1_u + mod2 <- liftST $ UnionFind.find mod2_u + case (mod1, mod2) of + (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u + (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u + (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do + when (mod_name1 /= mod_name2) $ + failWith $ + hang (text "Cannot match module names") 4 $ + text " " + <+> pretty mod_name1 + $$ text "and" + <+> pretty mod_name2 + -- NB: this is not actually necessary (because we'll + -- detect loops eventually in 'unifyUnitId'), but it + -- seems harmless enough + liftST $ UnionFind.union mod1_u mod2_u + unifyUnitId uid1 uid2 diff --git a/src/Distribution/Backpack/ModSubst.hs b/src/Distribution/Backpack/ModSubst.hs --- a/src/Distribution/Backpack/ModSubst.hs +++ b/src/Distribution/Backpack/ModSubst.hs @@ -5,13 +5,12 @@ -- applied to them. -- -- See also - -module Distribution.Backpack.ModSubst ( - ModSubst(..), -) where +module Distribution.Backpack.ModSubst + ( ModSubst (..) + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () import Distribution.Backpack import Distribution.ModuleName @@ -21,32 +20,33 @@ -- | Applying module substitutions to semantic objects. class ModSubst a where - -- In notation, substitution is postfix, which implies - -- putting it on the right hand side, but for partial - -- application it's more convenient to have it on the left - -- hand side. - modSubst :: OpenModuleSubst -> a -> a + -- In notation, substitution is postfix, which implies + -- putting it on the right hand side, but for partial + -- application it's more convenient to have it on the left + -- hand side. + modSubst :: OpenModuleSubst -> a -> a instance ModSubst OpenModule where - modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name - modSubst subst mod@(OpenModuleVar mod_name) - | Just mod' <- Map.lookup mod_name subst = mod' - | otherwise = mod + modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name + modSubst subst mod@(OpenModuleVar mod_name) + | Just mod' <- Map.lookup mod_name subst = mod' + | otherwise = mod instance ModSubst OpenUnitId where - modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) - modSubst _subst uid = uid + modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts) + modSubst _subst uid = uid instance ModSubst (Set ModuleName) where - modSubst subst reqs - = Set.union (Set.difference reqs (Map.keysSet subst)) - (openModuleSubstFreeHoles subst) + modSubst subst reqs = + Set.union + (Set.difference reqs (Map.keysSet subst)) + (openModuleSubstFreeHoles subst) -- Substitutions are functorial. NB: this means that -- there is an @instance 'ModSubst' 'ModuleSubst'@! instance ModSubst a => ModSubst (Map k a) where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst [a] where - modSubst subst = fmap (modSubst subst) + modSubst subst = fmap (modSubst subst) instance ModSubst a => ModSubst (k, a) where - modSubst subst (x,y) = (x, modSubst subst y) + modSubst subst (x, y) = (x, modSubst subst y) diff --git a/src/Distribution/Backpack/ModuleScope.hs b/src/Distribution/Backpack/ModuleScope.hs --- a/src/Distribution/Backpack/ModuleScope.hs +++ b/src/Distribution/Backpack/ModuleScope.hs @@ -1,30 +1,29 @@ -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} + -- | See -module Distribution.Backpack.ModuleScope ( - -- * Module scopes - ModuleScope(..), - ModuleProvides, - ModuleRequires, - ModuleSource(..), - dispModuleSource, - WithSource(..), - unWithSource, - getSource, - ModuleWithSource, - emptyModuleScope, -) where +module Distribution.Backpack.ModuleScope + ( -- * Module scopes + ModuleScope (..) + , ModuleProvides + , ModuleRequires + , ModuleSource (..) + , dispModuleSource + , WithSource (..) + , unWithSource + , getSource + , ModuleWithSource + , emptyModuleScope + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ModuleName -import Distribution.Types.IncludeRenaming -import Distribution.Types.PackageName +import Distribution.Pretty import Distribution.Types.ComponentName +import Distribution.Types.IncludeRenaming import Distribution.Types.LibraryName -import Distribution.Pretty +import Distribution.Types.PackageName import Distribution.Backpack import Distribution.Backpack.ModSubst @@ -32,7 +31,6 @@ import qualified Data.Map as Map import Text.PrettyPrint - ----------------------------------------------------------------------- -- Module scopes @@ -60,17 +58,16 @@ -- Alternate strategy: go ahead and unify, and then if it is revealed -- that some requirements got filled "out-of-thin-air", error. - -- | A 'ModuleScope' describes the modules and requirements that -- are in-scope as we are processing a Cabal package. Unlike -- a 'ModuleShape', there may be multiple modules in scope at -- the same 'ModuleName'; this is only an error if we attempt -- to use those modules to fill a requirement. A 'ModuleScope' -- can influence the 'ModuleShape' via a reexport. -data ModuleScope = ModuleScope { - modScopeProvides :: ModuleProvides, - modScopeRequires :: ModuleRequires - } +data ModuleScope = ModuleScope + { modScopeProvides :: ModuleProvides + , modScopeRequires :: ModuleRequires + } -- | An empty 'ModuleScope'. emptyModuleScope :: ModuleScope @@ -79,49 +76,53 @@ -- | Every 'Module' in scope at a 'ModuleName' is annotated with -- the 'PackageName' it comes from. type ModuleProvides = Map ModuleName [ModuleWithSource] + -- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m type ModuleRequires = Map ModuleName [ModuleWithSource] + -- TODO: consider newtping the two types above. -- | Description of where a module participating in mixin linking came -- from. data ModuleSource - = FromMixins PackageName ComponentName IncludeRenaming - | FromBuildDepends PackageName ComponentName - | FromExposedModules ModuleName - | FromOtherModules ModuleName - | FromSignatures ModuleName + = FromMixins PackageName ComponentName IncludeRenaming + | FromBuildDepends PackageName ComponentName + | FromExposedModules ModuleName + | FromOtherModules ModuleName + | FromSignatures ModuleName + -- We don't have line numbers, but if we did, we'd want to record that -- too -- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg dispModuleSource :: ModuleSource -> Doc -dispModuleSource (FromMixins pn cn incls) - = text "mixins:" <+> dispComponent pn cn <+> pretty incls -dispModuleSource (FromBuildDepends pn cn) - = text "build-depends:" <+> dispComponent pn cn -dispModuleSource (FromExposedModules m) - = text "exposed-modules:" <+> pretty m -dispModuleSource (FromOtherModules m) - = text "other-modules:" <+> pretty m -dispModuleSource (FromSignatures m) - = text "signatures:" <+> pretty m +dispModuleSource (FromMixins pn cn incls) = + text "mixins:" <+> dispComponent pn cn <+> pretty incls +dispModuleSource (FromBuildDepends pn cn) = + text "build-depends:" <+> dispComponent pn cn +dispModuleSource (FromExposedModules m) = + text "exposed-modules:" <+> pretty m +dispModuleSource (FromOtherModules m) = + text "other-modules:" <+> pretty m +dispModuleSource (FromSignatures m) = + text "signatures:" <+> pretty m -- Dependency dispComponent :: PackageName -> ComponentName -> Doc dispComponent pn cn = - -- NB: This syntax isn't quite the source syntax, but it - -- should be clear enough. To do source syntax, we'd - -- need to know what the package we're linking is. - case cn of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn - -- Case below shouldn't happen - _ -> pretty pn <+> parens (pretty cn) + -- NB: This syntax isn't quite the source syntax, but it + -- should be clear enough. To do source syntax, we'd + -- need to know what the package we're linking is. + case cn of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn + -- Case below shouldn't happen + _ -> pretty pn <+> parens (pretty cn) -- | An 'OpenModule', annotated with where it came from in a Cabal file. data WithSource a = WithSource ModuleSource a - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Traversable) + unWithSource :: WithSource a -> a unWithSource (WithSource _ x) = x getSource :: WithSource a -> ModuleSource @@ -129,4 +130,4 @@ type ModuleWithSource = WithSource OpenModule instance ModSubst a => ModSubst (WithSource a) where - modSubst subst (WithSource s m) = WithSource s (modSubst subst m) + modSubst subst (WithSource s m) = WithSource s (modSubst subst m) diff --git a/src/Distribution/Backpack/ModuleShape.hs b/src/Distribution/Backpack/ModuleShape.hs --- a/src/Distribution/Backpack/ModuleShape.hs +++ b/src/Distribution/Backpack/ModuleShape.hs @@ -1,21 +1,21 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + -- | See -module Distribution.Backpack.ModuleShape ( - -- * Module shapes - ModuleShape(..), - emptyModuleShape, - shapeInstalledPackage, -) where +module Distribution.Backpack.ModuleShape + ( -- * Module shapes + ModuleShape (..) + , emptyModuleShape + , shapeInstalledPackage + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.ModuleName import Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName -import Distribution.Backpack.ModSubst import Distribution.Backpack +import Distribution.Backpack.ModSubst import qualified Data.Map as Map import qualified Data.Set as Set @@ -26,18 +26,18 @@ -- | A 'ModuleShape' describes the provisions and requirements of -- a library. We can extract a 'ModuleShape' from an -- 'InstalledPackageInfo'. -data ModuleShape = ModuleShape { - modShapeProvides :: OpenModuleSubst, - modShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic, Typeable) +data ModuleShape = ModuleShape + { modShapeProvides :: OpenModuleSubst + , modShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) instance Binary ModuleShape instance Structured ModuleShape instance ModSubst ModuleShape where - modSubst subst (ModuleShape provs reqs) - = ModuleShape (modSubst subst provs) (modSubst subst reqs) + modSubst subst (ModuleShape provs reqs) = + ModuleShape (modSubst subst provs) (modSubst subst reqs) -- | The default module shape, with no provisions and no requirements. emptyModuleShape :: ModuleShape @@ -78,7 +78,7 @@ uid = installedOpenUnitId ipi provs = map shapeExposedModule (IPI.exposedModules ipi) reqs = requiredSignatures ipi - shapeExposedModule (IPI.ExposedModule mod_name Nothing) - = (mod_name, OpenModule uid mod_name) - shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) - = (mod_name, mod) + shapeExposedModule (IPI.ExposedModule mod_name Nothing) = + (mod_name, OpenModule uid mod_name) + shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) = + (mod_name, mod) diff --git a/src/Distribution/Backpack/PreExistingComponent.hs b/src/Distribution/Backpack/PreExistingComponent.hs --- a/src/Distribution/Backpack/PreExistingComponent.hs +++ b/src/Distribution/Backpack/PreExistingComponent.hs @@ -1,59 +1,70 @@ -- | See -module Distribution.Backpack.PreExistingComponent ( - PreExistingComponent(..), - ipiToPreExistingComponent, -) where +module Distribution.Backpack.PreExistingComponent + ( PreExistingComponent (..) + , ConfiguredPromisedComponent (..) + , ipiToPreExistingComponent + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Backpack.ModuleShape import Distribution.Backpack -import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName +import Distribution.Backpack.ModuleShape import Distribution.Package +import Distribution.Types.ComponentName +import Distribution.Types.MungedPackageId import qualified Data.Map as Map -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Types.AnnotatedId +-- | A /promised/ component. +-- +-- These components are promised to @configure@ but are not yet built. +-- +-- In other words this is 'PreExistingComponent' which doesn't yet exist. +data ConfiguredPromisedComponent = ConfiguredPromisedComponent + { pr_pkgname :: PackageName + , pr_cid :: AnnotatedId ComponentId + } + +instance Package ConfiguredPromisedComponent where + packageId = packageId . pr_cid + -- | Stripped down version of 'LinkedComponent' for things -- we don't need to know how to build. -data PreExistingComponent - = PreExistingComponent { - -- | The actual name of the package. This may DISAGREE with 'pc_pkgid' - -- for internal dependencies: e.g., an internal component @lib@ may be - -- munged to @z-pkg-z-lib@, but we still want to use it when we see - -- @lib@ in @build-depends@ - pc_pkgname :: PackageName, - -- | The actual name of the component. - pc_compname :: ComponentName, - pc_munged_id :: MungedPackageId, - pc_uid :: UnitId, - pc_cid :: ComponentId, - pc_open_uid :: OpenUnitId, - pc_shape :: ModuleShape - } +data PreExistingComponent = PreExistingComponent + { pc_pkgname :: PackageName + -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid' + -- for internal dependencies: e.g., an internal component @lib@ may be + -- munged to @z-pkg-z-lib@, but we still want to use it when we see + -- @lib@ in @build-depends@ + , pc_compname :: ComponentName + -- ^ The actual name of the component. + , pc_munged_id :: MungedPackageId + , pc_uid :: UnitId + , pc_cid :: ComponentId + , pc_open_uid :: OpenUnitId + , pc_shape :: ModuleShape + } -- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent', -- which was brought into scope under the 'PackageName' (important for -- a package qualified reference.) ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent ipiToPreExistingComponent ipi = - PreExistingComponent { - pc_pkgname = packageName ipi, - pc_compname = CLibName $ Installed.sourceLibName ipi, - pc_munged_id = mungedId ipi, - pc_uid = Installed.installedUnitId ipi, - pc_cid = Installed.installedComponentId ipi, - pc_open_uid = - IndefFullUnitId (Installed.installedComponentId ipi) - (Map.fromList (Installed.instantiatedWith ipi)), - pc_shape = shapeInstalledPackage ipi + PreExistingComponent + { pc_pkgname = packageName ipi + , pc_compname = CLibName $ Installed.sourceLibName ipi + , pc_munged_id = mungedId ipi + , pc_uid = Installed.installedUnitId ipi + , pc_cid = Installed.installedComponentId ipi + , pc_open_uid = + IndefFullUnitId + (Installed.installedComponentId ipi) + (Map.fromList (Installed.instantiatedWith ipi)) + , pc_shape = shapeInstalledPackage ipi } instance HasMungedPackageId PreExistingComponent where @@ -61,7 +72,8 @@ instance Package PreExistingComponent where packageId pec = PackageIdentifier (pc_pkgname pec) v - where MungedPackageId _ v = pc_munged_id pec + where + MungedPackageId _ v = pc_munged_id pec instance HasUnitId PreExistingComponent where installedUnitId = pc_uid diff --git a/src/Distribution/Backpack/PreModuleShape.hs b/src/Distribution/Backpack/PreModuleShape.hs --- a/src/Distribution/Backpack/PreModuleShape.hs +++ b/src/Distribution/Backpack/PreModuleShape.hs @@ -1,38 +1,37 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Backpack.PreModuleShape ( - PreModuleShape(..), - toPreModuleShape, - renamePreModuleShape, - mixLinkPreModuleShape, -) where +module Distribution.Backpack.PreModuleShape + ( PreModuleShape (..) + , toPreModuleShape + , renamePreModuleShape + , mixLinkPreModuleShape + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import qualified Data.Set as Set import qualified Data.Map as Map +import qualified Data.Set as Set import Distribution.Backpack.ModuleShape +import Distribution.ModuleName import Distribution.Types.IncludeRenaming import Distribution.Types.ModuleRenaming -import Distribution.ModuleName -data PreModuleShape = PreModuleShape { - preModShapeProvides :: Set ModuleName, - preModShapeRequires :: Set ModuleName - } - deriving (Eq, Show, Generic) +data PreModuleShape = PreModuleShape + { preModShapeProvides :: Set ModuleName + , preModShapeRequires :: Set ModuleName + } + deriving (Eq, Show, Generic) toPreModuleShape :: ModuleShape -> PreModuleShape toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) = - PreModuleShape - (Set.fromList (mapMaybe prov_fn (Set.toList provs))) - (Set.map req_fn reqs) + PreModuleShape + (Set.fromList (mapMaybe prov_fn (Set.toList provs))) + (Set.map req_fn reqs) where prov_fn = interpModuleRenaming prov_rn req_fn k = fromMaybe k (interpModuleRenaming req_rn k) @@ -41,4 +40,4 @@ mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs) where provs = Set.unions (map preModShapeProvides shapes) - reqs = Set.unions (map preModShapeRequires shapes) + reqs = Set.unions (map preModShapeRequires shapes) diff --git a/src/Distribution/Backpack/ReadyComponent.hs b/src/Distribution/Backpack/ReadyComponent.hs --- a/src/Distribution/Backpack/ReadyComponent.hs +++ b/src/Distribution/Backpack/ReadyComponent.hs @@ -1,186 +1,199 @@ -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeFamilies #-} + -- | See -module Distribution.Backpack.ReadyComponent ( - ReadyComponent(..), - InstantiatedComponent(..), - IndefiniteComponent(..), - rc_depends, - rc_uid, - rc_pkgid, - dispReadyComponent, - toReadyComponents, -) where +module Distribution.Backpack.ReadyComponent + ( ReadyComponent (..) + , InstantiatedComponent (..) + , IndefiniteComponent (..) + , rc_depends + , rc_uid + , rc_pkgid + , dispReadyComponent + , toReadyComponents + ) where -import Prelude () import Distribution.Compat.Prelude hiding ((<>)) +import Prelude () import Distribution.Backpack import Distribution.Backpack.LinkedComponent import Distribution.Backpack.ModuleShape +import Distribution.Compat.Graph (IsNode (..)) import Distribution.Types.AnnotatedId -import Distribution.Types.ModuleRenaming import Distribution.Types.Component -import Distribution.Types.ComponentInclude import Distribution.Types.ComponentId +import Distribution.Types.ComponentInclude import Distribution.Types.ComponentName -import Distribution.Types.PackageId -import Distribution.Types.PackageName.Magic -import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Types.Library +import Distribution.Types.LibraryName import Distribution.Types.Module +import Distribution.Types.ModuleRenaming import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Types.Library -import Distribution.Types.LibraryName +import Distribution.Types.PackageId +import Distribution.Types.PackageName.Magic +import Distribution.Types.UnitId import Distribution.ModuleName import Distribution.Package import Distribution.Simple.Utils import Control.Monad -import Text.PrettyPrint import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint -import Distribution.Version import Distribution.Pretty +import Distribution.Version -- | A 'ReadyComponent' is one that we can actually generate build -- products for. We have a ready component for the typecheck-only -- products of every indefinite package, as well as a ready component -- for every way these packages can be fully instantiated. --- -data ReadyComponent - = ReadyComponent { - rc_ann_id :: AnnotatedId UnitId, - -- | The 'OpenUnitId' for this package. At the moment, this - -- is used in only one case, which is to determine if an - -- export is of a module from this library (indefinite - -- libraries record these exports as 'OpenModule'); - -- 'rc_open_uid' can be conveniently used to test for - -- equality, whereas 'UnitId' cannot always be used in this - -- case. - rc_open_uid :: OpenUnitId, - -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' - -- records a 'ComponentId', it coincides with this one. - rc_cid :: ComponentId, - -- | Corresponds to 'lc_component'. - rc_component :: Component, - -- | Corresponds to 'lc_exe_deps'. - -- Build-tools don't participate in mix-in linking. - -- (but what if they could?) - rc_exe_deps :: [AnnotatedId UnitId], - -- | Corresponds to 'lc_public'. - rc_public :: Bool, - -- | Extra metadata depending on whether or not this is an - -- indefinite library (typechecked only) or an instantiated - -- component (can be compiled). - rc_i :: Either IndefiniteComponent InstantiatedComponent - } +data ReadyComponent = ReadyComponent + { rc_ann_id :: AnnotatedId UnitId + , rc_open_uid :: OpenUnitId + -- ^ The 'OpenUnitId' for this package. At the moment, this + -- is used in only one case, which is to determine if an + -- export is of a module from this library (indefinite + -- libraries record these exports as 'OpenModule'); + -- 'rc_open_uid' can be conveniently used to test for + -- equality, whereas 'UnitId' cannot always be used in this + -- case. + , rc_cid :: ComponentId + -- ^ Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid' + -- records a 'ComponentId', it coincides with this one. + , rc_component :: Component + -- ^ Corresponds to 'lc_component'. + , rc_exe_deps :: [AnnotatedId UnitId] + -- ^ Corresponds to 'lc_exe_deps'. + -- Build-tools don't participate in mix-in linking. + -- (but what if they could?) + , rc_public :: Bool + -- ^ Corresponds to 'lc_public'. + , rc_i :: Either IndefiniteComponent InstantiatedComponent + -- ^ Extra metadata depending on whether or not this is an + -- indefinite library (typechecked only) or an instantiated + -- component (can be compiled). + } -- | The final, string 'UnitId' that will uniquely identify -- the compilation products of this component. -rc_uid :: ReadyComponent -> UnitId +rc_uid :: ReadyComponent -> UnitId rc_uid = ann_id . rc_ann_id -- | Corresponds to 'lc_pkgid'. -rc_pkgid :: ReadyComponent -> PackageId +rc_pkgid :: ReadyComponent -> PackageId rc_pkgid = ann_pid . rc_ann_id -- | An 'InstantiatedComponent' is a library which is fully instantiated -- (or, possibly, has no requirements at all.) -data InstantiatedComponent - = InstantiatedComponent { - -- | How this library was instantiated. - instc_insts :: [(ModuleName, Module)], - -- | Dependencies induced by 'instc_insts'. These are recorded - -- here because there isn't a convenient way otherwise to get - -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. - instc_insts_deps :: [(UnitId, MungedPackageId)], - -- | The modules exported/reexported by this library. - instc_provides :: Map ModuleName Module, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These always refer to installed - -- fully instantiated libraries. - instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] - } +data InstantiatedComponent = InstantiatedComponent + { instc_insts :: [(ModuleName, Module)] + -- ^ How this library was instantiated. + , instc_insts_deps :: [(UnitId, MungedPackageId)] + -- ^ Dependencies induced by 'instc_insts'. These are recorded + -- here because there isn't a convenient way otherwise to get + -- the 'PackageId' we need to fill 'componentPackageDeps' as needed. + , instc_provides :: Map ModuleName Module + -- ^ The modules exported/reexported by this library. + , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These always refer to installed + -- fully instantiated libraries. + } -- | An 'IndefiniteComponent' is a library with requirements -- which we will typecheck only. -data IndefiniteComponent - = IndefiniteComponent { - -- | The requirements of the library. - indefc_requires :: [ModuleName], - -- | The modules exported/reexported by this library. - indefc_provides :: Map ModuleName OpenModule, - -- | The dependencies which need to be passed to the compiler - -- to bring modules into scope. These are 'OpenUnitId' because - -- these may refer to partially instantiated libraries. - indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] - } +data IndefiniteComponent = IndefiniteComponent + { indefc_requires :: [ModuleName] + -- ^ The requirements of the library. + , indefc_provides :: Map ModuleName OpenModule + -- ^ The modules exported/reexported by this library. + , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming] + -- ^ The dependencies which need to be passed to the compiler + -- to bring modules into scope. These are 'OpenUnitId' because + -- these may refer to partially instantiated libraries. + } -- | Compute the dependencies of a 'ReadyComponent' that should -- be recorded in the @depends@ field of 'InstalledPackageInfo'. rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)] rc_depends rc = ordNub $ - case rc_i rc of - Left indefc -> - map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) - (indefc_includes indefc) - Right instc -> - map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) - (instc_includes instc) - ++ instc_insts_deps instc + case rc_i rc of + Left indefc -> + map + (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci)) + (indefc_includes indefc) + Right instc -> + map + (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci)) + (instc_includes instc) + ++ instc_insts_deps instc where toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId toMungedPackageId ci = - computeCompatPackageId - (ci_pkgid ci) - (case ci_cname ci of - CLibName name -> name - _ -> error $ prettyShow (rc_cid rc) ++ - " depends on non-library " ++ prettyShow (ci_id ci)) + computeCompatPackageId + (ci_pkgid ci) + ( case ci_cname ci of + CLibName name -> name + _ -> + error $ + prettyShow (rc_cid rc) + ++ " depends on non-library " + ++ prettyShow (ci_id ci) + ) -- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is -- a library. rc_munged_id :: ReadyComponent -> MungedPackageId rc_munged_id rc = - computeCompatPackageId - (rc_pkgid rc) - (case rc_component rc of - CLib lib -> libName lib - _ -> error "rc_munged_id: not library") + computeCompatPackageId + (rc_pkgid rc) + ( case rc_component rc of + CLib lib -> libName lib + _ -> error "rc_munged_id: not library" + ) instance Package ReadyComponent where - packageId = rc_pkgid + packageId = rc_pkgid instance HasUnitId ReadyComponent where - installedUnitId = rc_uid + installedUnitId = rc_uid instance IsNode ReadyComponent where - type Key ReadyComponent = UnitId - nodeKey = rc_uid - nodeNeighbors rc = - (case rc_i rc of - Right inst | [] <- instc_insts inst - -> [] - | otherwise - -> [newSimpleUnitId (rc_cid rc)] - _ -> []) ++ - ordNub (map fst (rc_depends rc)) ++ - map ann_id (rc_exe_deps rc) + type Key ReadyComponent = UnitId + nodeKey = rc_uid + nodeNeighbors rc = + ( case rc_i rc of + Right inst + | [] <- instc_insts inst -> + [] + | otherwise -> + [newSimpleUnitId (rc_cid rc)] + _ -> [] + ) + ++ ordNub (map fst (rc_depends rc)) + ++ map ann_id (rc_exe_deps rc) dispReadyComponent :: ReadyComponent -> Doc dispReadyComponent rc = - hang (text (case rc_i rc of - Left _ -> "indefinite" - Right _ -> "definite") - <+> pretty (nodeKey rc) - {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $ - vcat [ text "depends" <+> pretty uid - | uid <- nodeNeighbors rc ] + hang + ( text + ( case rc_i rc of + Left _ -> "indefinite" + Right _ -> "definite" + ) + <+> pretty (nodeKey rc) + {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} + ) + 4 + $ vcat + [ text "depends" <+> pretty uid + | uid <- nodeNeighbors rc + ] -- | The state of 'InstM'; a mapping from 'UnitId's to their -- ready component, or @Nothing@ if its an external @@ -189,22 +202,25 @@ -- | A state monad for doing instantiations (can't use actual -- State because that would be an extra dependency.) -newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) } +newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)} instance Functor InstM where - fmap f (InstM m) = InstM $ \s -> let (x, s') = m s - in (f x, s') + fmap f (InstM m) = InstM $ \s -> + let (x, s') = m s + in (f x, s') instance Applicative InstM where - pure a = InstM $ \s -> (a, s) - InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s - (x', s'') = x s' - in (f' x', s'') + pure a = InstM $ \s -> (a, s) + InstM f <*> InstM x = InstM $ \s -> + let (f', s') = f s + (x', s'') = x s' + in (f' x', s'') instance Monad InstM where - return = pure - InstM m >>= f = InstM $ \s -> let (x, s') = m s - in runInstM (f x) s' + return = pure + InstM m >>= f = InstM $ \s -> + let (x, s') = m s + in runInstM (f x) s' -- | Given a list of 'LinkedComponent's, expand the module graph -- so that we have an instantiated graph containing all of the @@ -222,27 +238,30 @@ -- -- We also call 'improveUnitId' during this process, so that fully -- instantiated components are given 'HashedUnitId'. --- toReadyComponents - :: Map UnitId MungedPackageId - -> Map ModuleName Module -- subst for the public component - -> [LinkedComponent] - -> [ReadyComponent] -toReadyComponents pid_map subst0 comps - = catMaybes (Map.elems ready_map) + :: Map UnitId MungedPackageId + -> Map ModuleName Module -- subst for the public component + -> [LinkedComponent] + -> [ReadyComponent] +toReadyComponents pid_map subst0 comps = + catMaybes (Map.elems ready_map) where - cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ] + cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps] - instantiateUnitId :: ComponentId -> Map ModuleName Module - -> InstM DefUnitId + instantiateUnitId + :: ComponentId + -> Map ModuleName Module + -> InstM DefUnitId instantiateUnitId cid insts = InstM $ \s -> - case Map.lookup uid s of - Nothing -> - -- Knot tied - let (r, s') = runInstM (instantiateComponent uid cid insts) - (Map.insert uid r s) - in (def_uid, Map.insert uid r s') - Just _ -> (def_uid, s) + case Map.lookup uid s of + Nothing -> + -- Knot tied + let (r, s') = + runInstM + (instantiateComponent uid cid insts) + (Map.insert uid r s) + in (def_uid, Map.insert uid r s') + Just _ -> (def_uid, s) where -- The mkDefUnitId here indicates that we assume -- that Cabal handles unit id hash allocation. @@ -252,125 +271,142 @@ uid = unDefUnitId def_uid instantiateComponent - :: UnitId -> ComponentId -> Map ModuleName Module - -> InstM (Maybe ReadyComponent) + :: UnitId + -> ComponentId + -> Map ModuleName Module + -> InstM (Maybe ReadyComponent) instantiateComponent uid cid insts | Just lc <- Map.lookup cid cmap = do - provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) - -- NB: lc_sig_includes is omitted here, because we don't - -- need them to build - includes <- forM (lc_includes lc) $ \ci -> do - uid' <- substUnitId insts (ci_id ci) - return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) } - exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) - s <- InstM $ \s -> (s, s) - let getDep (Module dep_def_uid _) - | let dep_uid = unDefUnitId dep_def_uid + provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc)) + -- NB: lc_sig_includes is omitted here, because we don't + -- need them to build + includes <- forM (lc_includes lc) $ \ci -> do + uid' <- substUnitId insts (ci_id ci) + return ci{ci_ann_id = fmap (const uid') (ci_ann_id ci)} + exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc) + s <- InstM $ \s -> (s, s) + let getDep (Module dep_def_uid _) + | let dep_uid = unDefUnitId dep_def_uid = -- Lose DefUnitId invariant for rc_depends - = [(dep_uid, - fromMaybe err_pid $ - Map.lookup dep_uid pid_map <|> - fmap rc_munged_id (join (Map.lookup dep_uid s)))] - where - err_pid = MungedPackageId - (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) - (mkVersion [0]) - instc = InstantiatedComponent { - instc_insts = Map.toList insts, - instc_insts_deps = concatMap getDep (Map.elems insts), - instc_provides = provides, - instc_includes = includes - -- NB: there is no dependency on the - -- indefinite version of this instantiated package here, - -- as (1) it doesn't go in depends in the - -- IPI: it's not a run time dep, and (2) - -- we don't have to tell GHC about it, it - -- will match up the ComponentId - -- automatically - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid), - rc_cid = lc_cid lc, - rc_component = lc_component lc, - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Right instc - } + [ + ( dep_uid + , fromMaybe err_pid $ + Map.lookup dep_uid pid_map + <|> fmap rc_munged_id (join (Map.lookup dep_uid s)) + ) + ] + where + err_pid = + MungedPackageId + (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName) + (mkVersion [0]) + instc = + InstantiatedComponent + { instc_insts = Map.toList insts + , instc_insts_deps = concatMap getDep (Map.elems insts) + , instc_provides = provides + , instc_includes = includes + -- NB: there is no dependency on the + -- indefinite version of this instantiated package here, + -- as (1) it doesn't go in depends in the + -- IPI: it's not a run time dep, and (2) + -- we don't have to tell GHC about it, it + -- will match up the ComponentId + -- automatically + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid) + , rc_cid = lc_cid lc + , rc_component = lc_component lc + , rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Right instc + } | otherwise = return Nothing substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId substUnitId _ (DefiniteUnitId uid) = - return uid + return uid substUnitId subst (IndefFullUnitId cid insts) = do - insts' <- substSubst subst insts - instantiateUnitId cid insts' + insts' <- substSubst subst insts + instantiateUnitId cid insts' -- NB: NOT composition - substSubst :: Map ModuleName Module - -> Map ModuleName OpenModule - -> InstM (Map ModuleName Module) + substSubst + :: Map ModuleName Module + -> Map ModuleName OpenModule + -> InstM (Map ModuleName Module) substSubst subst insts = traverse (substModule subst) insts substModule :: Map ModuleName Module -> OpenModule -> InstM Module substModule subst (OpenModuleVar mod_name) - | Just m <- Map.lookup mod_name subst = return m - | otherwise = error "substModule: non-closing substitution" + | Just m <- Map.lookup mod_name subst = return m + | otherwise = error "substModule: non-closing substitution" substModule subst (OpenModule uid mod_name) = do - uid' <- substUnitId subst uid - return (Module uid' mod_name) + uid' <- substUnitId subst uid + return (Module uid' mod_name) - substExeDep :: Map ModuleName Module - -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId) + substExeDep + :: Map ModuleName Module + -> AnnotatedId OpenUnitId + -> InstM (AnnotatedId UnitId) substExeDep insts exe_aid = do - exe_uid' <- substUnitId insts (ann_id exe_aid) - return exe_aid { ann_id = unDefUnitId exe_uid' } + exe_uid' <- substUnitId insts (ann_id exe_aid) + return exe_aid{ann_id = unDefUnitId exe_uid'} indefiniteUnitId :: ComponentId -> InstM UnitId indefiniteUnitId cid = do - let uid = newSimpleUnitId cid - r <- indefiniteComponent uid cid - InstM $ \s -> (uid, Map.insert uid r s) + let uid = newSimpleUnitId cid + r <- indefiniteComponent uid cid + InstM $ \s -> (uid, Map.insert uid r s) indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent) indefiniteComponent uid cid | Just lc <- Map.lookup cid cmap = do - -- We're going to process includes, in case some of them - -- are fully definite even without any substitution. We - -- want to build those too; see #5634. - inst_includes <- forM (lc_includes lc) $ \ci -> - if Set.null (openUnitIdFreeHoles (ci_id ci)) - then do uid' <- substUnitId Map.empty (ci_id ci) - return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) } - else return ci - exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) - let indefc = IndefiniteComponent { - indefc_requires = map fst (lc_insts lc), - indefc_provides = modShapeProvides (lc_shape lc), - indefc_includes = inst_includes ++ lc_sig_includes lc - } - return $ Just ReadyComponent { - rc_ann_id = (lc_ann_id lc) { ann_id = uid }, - rc_cid = lc_cid lc, - rc_open_uid = lc_uid lc, - rc_component = lc_component lc, - -- It's always fully built - rc_exe_deps = exe_deps, - rc_public = lc_public lc, - rc_i = Left indefc + -- We're going to process includes, in case some of them + -- are fully definite even without any substitution. We + -- want to build those too; see #5634. + inst_includes <- forM (lc_includes lc) $ \ci -> + if Set.null (openUnitIdFreeHoles (ci_id ci)) + then do + uid' <- substUnitId Map.empty (ci_id ci) + return $ ci{ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci)} + else return ci + exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc) + let indefc = + IndefiniteComponent + { indefc_requires = map fst (lc_insts lc) + , indefc_provides = modShapeProvides (lc_shape lc) + , indefc_includes = inst_includes ++ lc_sig_includes lc + } + return $ + Just + ReadyComponent + { rc_ann_id = (lc_ann_id lc){ann_id = uid} + , rc_cid = lc_cid lc + , rc_open_uid = lc_uid lc + , rc_component = lc_component lc + , -- It's always fully built + rc_exe_deps = exe_deps + , rc_public = lc_public lc + , rc_i = Left indefc } | otherwise = return Nothing ready_map = snd $ runInstM work Map.empty work - -- Top-level instantiation per subst0 - | not (Map.null subst0) - , [lc] <- filter lc_public (Map.elems cmap) - = do _ <- instantiateUnitId (lc_cid lc) subst0 - return () - | otherwise - = forM_ (Map.elems cmap) $ \lc -> + -- Top-level instantiation per subst0 + | not (Map.null subst0) + , [lc] <- filter lc_public (Map.elems cmap) = + do + _ <- instantiateUnitId (lc_cid lc) subst0 + return () + | otherwise = + forM_ (Map.elems cmap) $ \lc -> if null (lc_insts lc) - then instantiateUnitId (lc_cid lc) Map.empty >> return () - else indefiniteUnitId (lc_cid lc) >> return () + then instantiateUnitId (lc_cid lc) Map.empty >> return () + else indefiniteUnitId (lc_cid lc) >> return () diff --git a/src/Distribution/Backpack/UnifyM.hs b/src/Distribution/Backpack/UnifyM.hs --- a/src/Distribution/Backpack/UnifyM.hs +++ b/src/Distribution/Backpack/UnifyM.hs @@ -1,163 +1,163 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} --- | See -module Distribution.Backpack.UnifyM ( - -- * Unification monad - UnifyM, - runUnifyM, - failWith, - addErr, - failIfErrs, - tryM, - addErrContext, - addErrContextM, - liftST, - UnifEnv(..), - getUnifEnv, +-- | See +module Distribution.Backpack.UnifyM + ( -- * Unification monad + UnifyM + , runUnifyM + , failWith + , addErr + , failIfErrs + , tryM + , addErrContext + , addErrContextM + , liftST + , UnifEnv (..) + , getUnifEnv -- * Modules and unit IDs - ModuleU, - ModuleU'(..), - convertModule, - convertModuleU, - - UnitIdU, - UnitIdU'(..), - convertUnitId, - convertUnitIdU, - - ModuleSubstU, - convertModuleSubstU, - convertModuleSubst, - - ModuleScopeU, - emptyModuleScopeU, - convertModuleScopeU, - - ModuleWithSourceU, - - convertInclude, - convertModuleProvides, - convertModuleProvidesU, - -) where + , ModuleU + , ModuleU' (..) + , convertModule + , convertModuleU + , UnitIdU + , UnitIdU' (..) + , convertUnitId + , convertUnitIdU + , ModuleSubstU + , convertModuleSubstU + , convertModuleSubst + , ModuleScopeU + , emptyModuleScopeU + , convertModuleScopeU + , ModuleWithSourceU + , convertInclude + , convertModuleProvides + , convertModuleProvidesU + ) where -import Prelude () import Distribution.Compat.Prelude hiding (mod) +import Prelude () -import Distribution.Backpack.ModuleShape -import Distribution.Backpack.ModuleScope -import Distribution.Backpack.ModSubst -import Distribution.Backpack.FullUnitId import Distribution.Backpack +import Distribution.Backpack.FullUnitId +import Distribution.Backpack.ModSubst +import Distribution.Backpack.ModuleScope +import Distribution.Backpack.ModuleShape -import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.ModuleName import Distribution.Package import Distribution.PackageDescription import Distribution.Pretty -import Distribution.Types.ComponentInclude import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentInclude +import qualified Distribution.Utils.UnionFind as UnionFind import Distribution.Verbosity -import Data.STRef -import Data.Traversable import Control.Monad.ST -import qualified Data.Map as Map -import qualified Data.Set as Set import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.STRef +import qualified Data.Set as Set +import Data.Traversable import Text.PrettyPrint -- TODO: more detailed trace output on high verbosity would probably -- be appreciated by users debugging unification errors. Collect -- some good examples! -data ErrMsg = ErrMsg { - err_msg :: Doc, - err_ctx :: [Doc] - } +data ErrMsg = ErrMsg + { err_msg :: Doc + , err_ctx :: [Doc] + } type MsgDoc = Doc renderErrMsg :: ErrMsg -> MsgDoc -renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } = - msg $$ vcat ctx +renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} = + msg $$ vcat ctx -- | The unification monad, this monad encapsulates imperative -- unification. -newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) } +newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)} -- | Run a computation in the unification monad. runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a -runUnifyM verbosity self_cid db m - = runST $ do i <- newSTRef 0 - hmap <- newSTRef Map.empty - errs <- newSTRef [] - mb_r <- unUnifyM m UnifEnv { - unify_uniq = i, - unify_reqs = hmap, - unify_self_cid = self_cid, - unify_verbosity = verbosity, - unify_ctx = [], - unify_db = db, - unify_errs = errs } - final_errs <- readSTRef errs - case mb_r of - Just x | null final_errs -> return (Right x) - _ -> return (Left (map renderErrMsg (reverse final_errs))) +runUnifyM verbosity self_cid db m = + runST $ do + i <- newSTRef 0 + hmap <- newSTRef Map.empty + errs <- newSTRef [] + mb_r <- + unUnifyM + m + UnifEnv + { unify_uniq = i + , unify_reqs = hmap + , unify_self_cid = self_cid + , unify_verbosity = verbosity + , unify_ctx = [] + , unify_db = db + , unify_errs = errs + } + final_errs <- readSTRef errs + case mb_r of + Just x | null final_errs -> return (Right x) + _ -> return (Left (map renderErrMsg (reverse final_errs))) + -- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'. type ErrCtx s = MsgDoc -- | The unification environment. -data UnifEnv s = UnifEnv { - -- | A supply of unique integers to label 'UnitIdU' - -- cells. This is used to determine loops in unit - -- identifiers (which can happen with mutual recursion.) - unify_uniq :: UnifRef s UnitIdUnique, - -- | The set of requirements in scope. When - -- a provision is brought into scope, we unify with - -- the requirement at the same module name to fill it. - -- This mapping grows monotonically. - unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)), - -- | Component id of the unit we're linking. We use this - -- to detect if we fill a requirement with a local module, - -- which in principle should be OK but is not currently - -- supported by GHC. - unify_self_cid :: ComponentId, - -- | How verbose the error message should be - unify_verbosity :: Verbosity, - -- | The error reporting context - unify_ctx :: [ErrCtx s], - -- | The package index for expanding unit identifiers - unify_db :: FullDb, - -- | Accumulated errors - unify_errs :: UnifRef s [ErrMsg] - } +data UnifEnv s = UnifEnv + { unify_uniq :: UnifRef s UnitIdUnique + -- ^ A supply of unique integers to label 'UnitIdU' + -- cells. This is used to determine loops in unit + -- identifiers (which can happen with mutual recursion.) + , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)) + -- ^ The set of requirements in scope. When + -- a provision is brought into scope, we unify with + -- the requirement at the same module name to fill it. + -- This mapping grows monotonically. + , unify_self_cid :: ComponentId + -- ^ Component id of the unit we're linking. We use this + -- to detect if we fill a requirement with a local module, + -- which in principle should be OK but is not currently + -- supported by GHC. + , unify_verbosity :: Verbosity + -- ^ How verbose the error message should be + , unify_ctx :: [ErrCtx s] + -- ^ The error reporting context + , unify_db :: FullDb + -- ^ The package index for expanding unit identifiers + , unify_errs :: UnifRef s [ErrMsg] + -- ^ Accumulated errors + } instance Functor (UnifyM s) where - fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) + fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m) instance Applicative (UnifyM s) where - pure = UnifyM . pure . pure . pure - UnifyM f <*> UnifyM x = UnifyM $ \r -> do - f' <- f r - case f' of + pure = UnifyM . pure . pure . pure + UnifyM f <*> UnifyM x = UnifyM $ \r -> do + f' <- f r + case f' of + Nothing -> return Nothing + Just f'' -> do + x' <- x r + case x' of Nothing -> return Nothing - Just f'' -> do - x' <- x r - case x' of - Nothing -> return Nothing - Just x'' -> return (Just (f'' x'')) + Just x'' -> return (Just (f'' x'')) instance Monad (UnifyM s) where - return = pure - UnifyM m >>= f = UnifyM $ \r -> do - x <- m r - case x of - Nothing -> return Nothing - Just x' -> unUnifyM (f x') r + return = pure + UnifyM m >>= f = UnifyM $ \r -> do + x <- m r + case x of + Nothing -> return Nothing + Just x' -> unUnifyM (f x') r -- | Lift a computation from 'ST' monad to 'UnifyM' monad. -- Internal use only. @@ -166,32 +166,35 @@ addErr :: MsgDoc -> UnifyM s () addErr msg = do - env <- getUnifEnv - let err = ErrMsg { - err_msg = msg, - err_ctx = unify_ctx env - } - liftST $ modifySTRef (unify_errs env) (\errs -> err:errs) + env <- getUnifEnv + let err = + ErrMsg + { err_msg = msg + , err_ctx = unify_ctx env + } + liftST $ modifySTRef (unify_errs env) (\errs -> err : errs) failWith :: MsgDoc -> UnifyM s a failWith msg = do - addErr msg - failM + addErr msg + failM failM :: UnifyM s a failM = UnifyM $ \_ -> return Nothing failIfErrs :: UnifyM s () failIfErrs = do - env <- getUnifEnv - errs <- liftST $ readSTRef (unify_errs env) - when (not (null errs)) failM + env <- getUnifEnv + errs <- liftST $ readSTRef (unify_errs env) + when (not (null errs)) failM tryM :: UnifyM s a -> UnifyM s (Maybe a) tryM m = - UnifyM (\env -> do + UnifyM + ( \env -> do mb_r <- unUnifyM m env - return (Just mb_r)) + return (Just mb_r) + ) {- otherFail :: ErrMsg -> UnifyM s a @@ -236,8 +239,7 @@ -- | Add a message to the error context. It may make monadic queries. addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a addErrContextM ctx m = - UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r } - + UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r} ----------------------------------------------------------------------- -- The "unifiable" variants of the data types @@ -251,13 +253,13 @@ -- | Contents of a mutable 'ModuleU' reference. data ModuleU' s - = ModuleU (UnitIdU s) ModuleName - | ModuleVarU ModuleName + = ModuleU (UnitIdU s) ModuleName + | ModuleVarU ModuleName -- | Contents of a mutable 'UnitIdU' reference. data UnitIdU' s - = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) - | UnitIdThunkU DefUnitId + = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s)) + | UnitIdThunkU DefUnitId -- | A mutable version of 'Module' which can be imperatively unified. type ModuleU s = UnionFind.Point s (ModuleU' s) @@ -273,7 +275,6 @@ -- participate in unification! type UnitIdUnique = Int - ----------------------------------------------------------------------- -- Conversion to the unifiable data types @@ -286,7 +287,7 @@ extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s extendMuEnv (m, i) x = - (IntMap.insert (i + 1) x m, i + 1) + (IntMap.insert (i + 1) x m, i + 1) {- lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s @@ -308,37 +309,42 @@ -- @hole:A@ binders. -- * @MuEnv@ - the environment for mu-binders. -convertUnitId' :: MuEnv s - -> OpenUnitId - -> UnifyM s (UnitIdU s) +convertUnitId' + :: MuEnv s + -> OpenUnitId + -> UnifyM s (UnitIdU s) -- TODO: this could be more lazy if we know there are no internal -- references convertUnitId' _ (DefiniteUnitId uid) = - liftST $ UnionFind.fresh (UnitIdThunkU uid) + liftST $ UnionFind.fresh (UnitIdThunkU uid) convertUnitId' stk (IndefFullUnitId cid insts) = do - fs <- fmap unify_uniq getUnifEnv - x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later - insts_u <- for insts $ convertModule' (extendMuEnv stk x) - u <- readUnifRef fs - writeUnifRef fs (u+1) - y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) - liftST $ UnionFind.union x y - return y + fs <- fmap unify_uniq getUnifEnv + x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later + insts_u <- for insts $ convertModule' (extendMuEnv stk x) + u <- readUnifRef fs + writeUnifRef fs (u + 1) + y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u) + liftST $ UnionFind.union x y + return y + -- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i) -convertModule' :: MuEnv s - -> OpenModule -> UnifyM s (ModuleU s) +convertModule' + :: MuEnv s + -> OpenModule + -> UnifyM s (ModuleU s) convertModule' _stk (OpenModuleVar mod_name) = do - hmap <- fmap unify_reqs getUnifEnv - hm <- readUnifRef hmap - case Map.lookup mod_name hm of - Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) - writeUnifRef hmap (Map.insert mod_name mod hm) - return mod - Just mod -> return mod + hmap <- fmap unify_reqs getUnifEnv + hm <- readUnifRef hmap + case Map.lookup mod_name hm of + Nothing -> do + mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name) + writeUnifRef hmap (Map.insert mod_name mod hm) + return mod + Just mod -> return mod convertModule' stk (OpenModule uid mod_name) = do - uid_u <- convertUnitId' stk uid - liftST $ UnionFind.fresh (ModuleU uid_u mod_name) + uid_u <- convertUnitId' stk uid + liftST $ UnionFind.fresh (ModuleU uid_u mod_name) convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s) convertUnitId = convertUnitId' emptyMuEnv @@ -346,8 +352,6 @@ convertModule :: OpenModule -> UnifyM s (ModuleU s) convertModule = convertModule' emptyMuEnv - - ----------------------------------------------------------------------- -- Substitutions @@ -380,38 +384,50 @@ lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int lookupMooEnv (m, i) k = - case IntMap.lookup k m of - Nothing -> Nothing - Just v -> Just (i-v) -- de Bruijn indexize + case IntMap.lookup k m of + Nothing -> Nothing + Just v -> Just (i - v) -- de Bruijn indexize -- The workhorse functions -convertUnitIdU' :: MooEnv -> UnitIdU s -> UnifyM s OpenUnitId -convertUnitIdU' stk uid_u = do - x <- liftST $ UnionFind.find uid_u - case x of - UnitIdThunkU uid -> return (DefiniteUnitId uid) - UnitIdU u cid insts_u -> - case lookupMooEnv stk u of - Just _i -> - failWith (text "Unsupported mutually recursive unit identifier") - -- return (UnitIdVar i) - Nothing -> do - insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) - return (IndefFullUnitId cid insts) +-- | Returns `OpenUnitId` if there is no a mutually recursive unit. +-- | Otherwise returns a list of signatures instantiated by given `UnitIdU`. +convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId +convertUnitIdU' stk uid_u required_mod_name = do + x <- liftST $ UnionFind.find uid_u + case x of + UnitIdThunkU uid -> return $ DefiniteUnitId uid + UnitIdU u cid insts_u -> + case lookupMooEnv stk u of + Just _ -> + let mod_names = Map.keys insts_u + in failWithMutuallyRecursiveUnitsError required_mod_name mod_names + Nothing -> do + insts <- for insts_u $ convertModuleU' (extendMooEnv stk u) + return $ IndefFullUnitId cid insts convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule convertModuleU' stk mod_u = do - mod <- liftST $ UnionFind.find mod_u - case mod of - ModuleVarU mod_name -> return (OpenModuleVar mod_name) - ModuleU uid_u mod_name -> do - uid <- convertUnitIdU' stk uid_u - return (OpenModule uid mod_name) + mod <- liftST $ UnionFind.find mod_u + case mod of + ModuleVarU mod_name -> return (OpenModuleVar mod_name) + ModuleU uid_u mod_name -> do + uid <- convertUnitIdU' stk uid_u (pretty mod_name) + return (OpenModule uid mod_name) +failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a +failWithMutuallyRecursiveUnitsError required_mod_name mod_names = + let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names + in failWith $ + text "Cannot instantiate requirement" + <+> quotes required_mod_name + $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:" + <+> sigsList + $$ text "as this creates a cyclic dependency, which GHC does not support." + -- Helper functions -convertUnitIdU :: UnitIdU s -> UnifyM s OpenUnitId +convertUnitIdU :: UnitIdU s -> Doc -> UnifyM s OpenUnitId convertUnitIdU = convertUnitIdU' emptyMooEnv convertModuleU :: ModuleU s -> UnifyM s OpenModule @@ -421,11 +437,12 @@ emptyModuleScopeU :: ModuleScopeU s emptyModuleScopeU = (Map.empty, Map.empty) - -- | The mutable counterpart of 'ModuleScope'. type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s) + -- | The mutable counterpart of 'ModuleProvides' type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s] + type ModuleRequiresU s = ModuleProvidesU s type ModuleWithSourceU s = WithSource (ModuleU s) @@ -437,33 +454,41 @@ where pn = pkgName (ci_pkgid ci) pp_pn = - case ci_cname ci of - CLibName LMainLibName -> pretty pn - CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn - -- Shouldn't happen - cn -> pretty pn <+> parens (pretty cn) + case ci_cname ci of + CLibName LMainLibName -> pretty pn + CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn + -- Shouldn't happen + cn -> pretty pn <+> parens (pretty cn) -- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do -- unification on it. convertInclude - :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming - -> UnifyM s (ModuleScopeU s, - Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -} - (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -}) -convertInclude ci@(ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = (uid, ModuleShape provs reqs), - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = incl@(IncludeRenaming prov_rns req_rns), - ci_implicit = implicit - }) = addErrContext (text "In" <+> ci_msg ci) $ do + :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming + -> UnifyM + s + ( ModuleScopeU s + , Either + (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -}) + (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -}) + ) +convertInclude + ci@( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = (uid, ModuleShape provs reqs) + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = incl@(IncludeRenaming prov_rns req_rns) + , ci_implicit = implicit + } + ) = addErrContext (text "In" <+> ci_msg ci) $ do let pn = packageName pid - the_source | implicit - = FromBuildDepends pn compname - | otherwise - = FromMixins pn compname incl + the_source + | implicit = + FromBuildDepends pn compname + | otherwise = + FromMixins pn compname incl source = WithSource the_source -- Suppose our package has two requirements A and B, and @@ -488,27 +513,31 @@ case req_rns of DefaultRenaming -> return [] HidingRenaming _ -> do - -- Not valid here for requires! - addErr $ text "Unsupported syntax" <+> - quotes (text "requires hiding (...)") - return [] + -- Not valid here for requires! + addErr $ + text "Unsupported syntax" + <+> quotes (text "requires hiding (...)") + return [] ModuleRenaming rns -> return rns let req_rename_listmap :: Map ModuleName [ModuleName] req_rename_listmap = - Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ] + Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list] req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 -> case vs0 of - [] -> error "req_rename" + [] -> error "req_rename" [v] -> return v - v:vs -> do addErr $ - text "Conflicting renamings of requirement" <+> quotes (pretty k) $$ - text "Renamed to: " <+> vcat (map pretty (v:vs)) - return v + v : vs -> do + addErr $ + text "Conflicting renamings of requirement" + <+> quotes (pretty k) + $$ text "Renamed to: " + <+> vcat (map pretty (v : vs)) + return v let req_rename_fn k = case Map.lookup k req_rename of - Nothing -> k - Just v -> v + Nothing -> k + Just v -> v -- Requirement substitution. -- @@ -523,19 +552,25 @@ -- mappings. -- -- A -> X ==> X -> , B -> - reqs_u <- convertModuleRequires . Map.fromList $ - [ (k, [source (OpenModuleVar k)]) - | k <- map req_rename_fn (Set.toList reqs) - ] + reqs_u <- + convertModuleRequires . Map.fromList $ + [ (k, [source (OpenModuleVar k)]) + | k <- map req_rename_fn (Set.toList reqs) + ] -- Report errors if there were unused renamings let leftover = Map.keysSet req_rename `Set.difference` reqs unless (Set.null leftover) $ - addErr $ - hang (text "The" <+> text (showComponentName compname) <+> - text "from package" <+> quotes (pretty pid) - <+> text "does not require:") 4 - (vcat (map pretty (Set.toList leftover))) + addErr $ + hang + ( text "The" + <+> text (showComponentName compname) + <+> text "from package" + <+> quotes (pretty pid) + <+> text "does not require:" + ) + 4 + (vcat (map pretty (Set.toList leftover))) -- Provision computation is more complex. -- For example, if we have: @@ -559,56 +594,72 @@ -- Importantly, overlapping rename targets get accumulated -- together. It's not an (immediate) error. (pre_prov_scope, prov_rns') <- - case prov_rns of - DefaultRenaming -> return (Map.toList provs, prov_rns) - HidingRenaming hides -> - let hides_set = Set.fromList hides - in let r = [ (k,v) - | (k,v) <- Map.toList provs - , not (k `Set.member` hides_set) ] - -- GHC doesn't understand hiding, so expand it out! - in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r)) - ModuleRenaming rns -> do - r <- sequence - [ case Map.lookup from provs of - Just m -> return (to, m) - Nothing -> failWith $ - text "Package" <+> quotes (pretty pid) <+> - text "does not expose the module" <+> quotes (pretty from) - | (from, to) <- rns ] - return (r, prov_rns) - let prov_scope = modSubst req_subst - $ Map.fromListWith (++) - [ (k, [source v]) - | (k, v) <- pre_prov_scope ] + case prov_rns of + DefaultRenaming -> return (Map.toList provs, prov_rns) + HidingRenaming hides -> + let hides_set = Set.fromList hides + in let r = + [ (k, v) + | (k, v) <- Map.toList provs + , not (k `Set.member` hides_set) + ] + in -- GHC doesn't understand hiding, so expand it out! + return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r)) + ModuleRenaming rns -> do + r <- + sequence + [ case Map.lookup from provs of + Just m -> return (to, m) + Nothing -> + failWith $ + text "Package" + <+> quotes (pretty pid) + <+> text "does not expose the module" + <+> quotes (pretty from) + | (from, to) <- rns + ] + return (r, prov_rns) + let prov_scope = + modSubst req_subst $ + Map.fromListWith + (++) + [ (k, [source v]) + | (k, v) <- pre_prov_scope + ] provs_u <- convertModuleProvides prov_scope -- TODO: Assert that provs_u is empty if provs was empty - return ((provs_u, reqs_u), - -- NB: We test that requirements is not null so that - -- users can create packages with zero module exports - -- that cause some C library to linked in, etc. - (if Map.null provs && not (Set.null reqs) - then Right -- is sig - else Left) (ComponentInclude { - ci_ann_id = AnnotatedId { - ann_id = uid_u, - ann_pid = pid, - ann_cname = compname - }, - ci_renaming = prov_rns', - ci_implicit = ci_implicit ci - })) + return + ( (provs_u, reqs_u) + , -- NB: We test that requirements is not null so that + -- users can create packages with zero module exports + -- that cause some C library to linked in, etc. + ( if Map.null provs && not (Set.null reqs) + then Right -- is sig + else Left + ) + ( ComponentInclude + { ci_ann_id = + AnnotatedId + { ann_id = uid_u + , ann_pid = pid + , ann_cname = compname + } + , ci_renaming = prov_rns' + , ci_implicit = ci_implicit ci + } + ) + ) -- | Convert a 'ModuleScopeU' to a 'ModuleScope'. convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope convertModuleScopeU (provs_u, reqs_u) = do - provs <- convertModuleProvidesU provs_u - reqs <- convertModuleRequiresU reqs_u - -- TODO: Test that the requirements are still free. If they - -- are not, they got unified, and that's dodgy at best. - return (ModuleScope provs reqs) + provs <- convertModuleProvidesU provs_u + reqs <- convertModuleRequiresU reqs_u + -- TODO: Test that the requirements are still free. If they + -- are not, they got unified, and that's dodgy at best. + return (ModuleScope provs reqs) -- | Convert a 'ModuleProvides' to a 'ModuleProvidesU' convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s) diff --git a/src/Distribution/CabalSpecVersion.hs b/src/Distribution/CabalSpecVersion.hs deleted file mode 100644 --- a/src/Distribution/CabalSpecVersion.hs +++ /dev/null @@ -1,150 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.CabalSpecVersion where - -import Prelude () -import Distribution.Compat.Prelude - --- | Different Cabal-the-spec versions. --- --- We branch based on this at least in the parser. --- -data CabalSpecVersion - = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2' - | CabalSpecV1_2 -- ^ new syntax (sections) - | CabalSpecV1_4 - | CabalSpecV1_6 - | CabalSpecV1_8 - | CabalSpecV1_10 - | CabalSpecV1_12 - -- 1.16 -- 1.14: no changes - | CabalSpecV1_18 - | CabalSpecV1_20 - | CabalSpecV1_22 - | CabalSpecV1_24 - | CabalSpecV2_0 - | CabalSpecV2_2 - | CabalSpecV2_4 - | CabalSpecV3_0 - -- 3.2: no changes - | CabalSpecV3_4 - | CabalSpecV3_6 - deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic) - -instance Binary CabalSpecVersion -instance Structured CabalSpecVersion -instance NFData CabalSpecVersion where rnf = genericRnf - --- | Show cabal spec version, but not the way in the .cabal files --- --- @since 3.0.0.0 -showCabalSpecVersion :: CabalSpecVersion -> String -showCabalSpecVersion CabalSpecV3_6 = "3.6" -showCabalSpecVersion CabalSpecV3_4 = "3.4" -showCabalSpecVersion CabalSpecV3_0 = "3.0" -showCabalSpecVersion CabalSpecV2_4 = "2.4" -showCabalSpecVersion CabalSpecV2_2 = "2.2" -showCabalSpecVersion CabalSpecV2_0 = "2.0" -showCabalSpecVersion CabalSpecV1_24 = "1.24" -showCabalSpecVersion CabalSpecV1_22 = "1.22" -showCabalSpecVersion CabalSpecV1_20 = "1.20" -showCabalSpecVersion CabalSpecV1_18 = "1.18" -showCabalSpecVersion CabalSpecV1_12 = "1.12" -showCabalSpecVersion CabalSpecV1_10 = "1.10" -showCabalSpecVersion CabalSpecV1_8 = "1.8" -showCabalSpecVersion CabalSpecV1_6 = "1.6" -showCabalSpecVersion CabalSpecV1_4 = "1.4" -showCabalSpecVersion CabalSpecV1_2 = "1.2" -showCabalSpecVersion CabalSpecV1_0 = "1.0" - -cabalSpecLatest :: CabalSpecVersion -cabalSpecLatest = CabalSpecV3_6 - --- | Parse 'CabalSpecVersion' from version digits. --- --- It may fail if for recent versions the version is not exact. --- -cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion -cabalSpecFromVersionDigits v - | v == [3,6] = Just CabalSpecV3_6 - | v == [3,4] = Just CabalSpecV3_4 - | v == [3,0] = Just CabalSpecV3_0 - | v == [2,4] = Just CabalSpecV2_4 - | v == [2,2] = Just CabalSpecV2_2 - | v == [2,0] = Just CabalSpecV2_0 - | v >= [1,25] = Nothing - | v >= [1,23] = Just CabalSpecV1_24 - | v >= [1,21] = Just CabalSpecV1_22 - | v >= [1,19] = Just CabalSpecV1_20 - | v >= [1,17] = Just CabalSpecV1_18 - | v >= [1,11] = Just CabalSpecV1_12 - | v >= [1,9] = Just CabalSpecV1_10 - | v >= [1,7] = Just CabalSpecV1_8 - | v >= [1,5] = Just CabalSpecV1_6 - | v >= [1,3] = Just CabalSpecV1_4 - | v >= [1,1] = Just CabalSpecV1_2 - | otherwise = Just CabalSpecV1_0 - --- | @since 3.4.0.0 -cabalSpecToVersionDigits :: CabalSpecVersion -> [Int] -cabalSpecToVersionDigits CabalSpecV3_6 = [3,6] -cabalSpecToVersionDigits CabalSpecV3_4 = [3,4] -cabalSpecToVersionDigits CabalSpecV3_0 = [3,0] -cabalSpecToVersionDigits CabalSpecV2_4 = [2,4] -cabalSpecToVersionDigits CabalSpecV2_2 = [2,2] -cabalSpecToVersionDigits CabalSpecV2_0 = [2,0] -cabalSpecToVersionDigits CabalSpecV1_24 = [1,24] -cabalSpecToVersionDigits CabalSpecV1_22 = [1,22] -cabalSpecToVersionDigits CabalSpecV1_20 = [1,20] -cabalSpecToVersionDigits CabalSpecV1_18 = [1,18] -cabalSpecToVersionDigits CabalSpecV1_12 = [1,12] -cabalSpecToVersionDigits CabalSpecV1_10 = [1,10] -cabalSpecToVersionDigits CabalSpecV1_8 = [1,8] -cabalSpecToVersionDigits CabalSpecV1_6 = [1,6] -cabalSpecToVersionDigits CabalSpecV1_4 = [1,4] -cabalSpecToVersionDigits CabalSpecV1_2 = [1,2] -cabalSpecToVersionDigits CabalSpecV1_0 = [1,0] - --- | What is the minimum Cabal library version which knows how handle --- this spec version. --- --- /Note:/ this is a point where we could decouple cabal-spec and Cabal --- versions, if we ever want that. --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV3_0 --- [2,5] --- --- >>> cabalSpecMinimumLibraryVersion CabalSpecV2_4 --- [2,3] --- --- @since 3.4.0.0 -cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int] -cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0] -cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of - [x,y] -> [x, y+1] - xs -> xs - -specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas -specHasCommonStanzas v = - if v >= CabalSpecV2_2 - then HasCommonStanzas - else NoCommonStanzas - -specHasElif :: CabalSpecVersion -> HasElif -specHasElif v = - if v >= CabalSpecV2_2 - then HasElif - else NoElif - -------------------------------------------------------------------------------- --- Booleans -------------------------------------------------------------------------------- - --- IDEA: make some kind of tagged booleans? -data HasElif = HasElif | NoElif - deriving (Eq, Show) - -data HasCommonStanzas = HasCommonStanzas | NoCommonStanzas - deriving (Eq, Show) - -data HasGlobstar = HasGlobstar | NoGlobstar diff --git a/src/Distribution/Compat/Async.hs b/src/Distribution/Compat/Async.hs --- a/src/Distribution/Compat/Async.hs +++ b/src/Distribution/Compat/Async.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -- | 'Async', yet using 'MVar's. -- -- Adopted from @async@ library @@ -7,35 +5,46 @@ -- Licensed under BSD-3-Clause -- -- @since 3.2.0.0 --- -module Distribution.Compat.Async ( - AsyncM, - withAsync, waitCatch, - wait, asyncThreadId, - cancel, uninterruptibleCancel, AsyncCancelled (..), +module Distribution.Compat.Async + ( AsyncM + , withAsync + , waitCatch + , wait + , asyncThreadId + , cancel + , uninterruptibleCancel + , AsyncCancelled (..) + -- * Cabal extras - withAsyncNF, - ) where + , withAsyncNF + ) where -import Control.Concurrent (ThreadId, forkIO) +import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) -import Control.DeepSeq (NFData, force) +import Control.DeepSeq (NFData, force) import Control.Exception - (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_) -import Control.Monad (void) -import Data.Typeable (Typeable) -import GHC.Exts (inline) - -#if MIN_VERSION_base(4,7,0) -import Control.Exception (asyncExceptionFromException, asyncExceptionToException) -#endif + ( BlockedIndefinitelyOnMVar (..) + , Exception (..) + , SomeException (..) + , asyncExceptionFromException + , asyncExceptionToException + , catch + , evaluate + , mask + , throwIO + , throwTo + , try + , uninterruptibleMask_ + ) +import Control.Monad (void) +import GHC.Exts (inline) -- | Async, but based on 'MVar', as we don't depend on @stm@. data AsyncM a = Async { asyncThreadId :: {-# UNPACK #-} !ThreadId - -- ^ Returns the 'ThreadId' of the thread running - -- the given 'Async'. - , _asyncMVar :: MVar (Either SomeException a) + -- ^ Returns the 'ThreadId' of the thread running + -- the given 'Async'. + , _asyncMVar :: MVar (Either SomeException a) } -- | Spawn an asynchronous action in a separate thread, and pass its @@ -52,12 +61,12 @@ -- Note: a reference to the child thread is kept alive until the call -- to `withAsync` returns, so nesting many `withAsync` calls requires -- linear memory. --- withAsync :: IO a -> (AsyncM a -> IO b) -> IO b withAsync = inline withAsyncUsing forkIO withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b -withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where +withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) + where evaluateNF = evaluate . force withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b @@ -68,7 +77,8 @@ mask $ \restore -> do t <- doFork $ try (restore action) >>= putMVar var let a = Async t var - r <- restore (inner a) `catchAll` \e -> do + r <- + restore (inner a) `catchAll` \e -> do uninterruptibleCancel a throwIO e uninterruptibleCancel a @@ -79,21 +89,19 @@ -- exception is re-thrown by 'wait'. -- -- > wait = atomically . waitSTM --- {-# INLINE wait #-} wait :: AsyncM a -> IO a wait a = do - res <- waitCatch a - case res of - Left (SomeException e) -> throwIO e - Right x -> return x + res <- waitCatch a + case res of + Left (SomeException e) -> throwIO e + Right x -> return x -- | Wait for an asynchronous action to complete, and return either -- @Left e@ if the action raised an exception @e@, or @Right a@ if it -- returned a value @a@. -- -- > waitCatch = atomically . waitCatchSTM --- {-# INLINE waitCatch #-} waitCatch :: AsyncM a -> IO (Either SomeException a) waitCatch (Async _ var) = tryAgain (readMVar var) @@ -123,22 +131,21 @@ {-# INLINE cancel #-} cancel :: AsyncM a -> IO () cancel a@(Async t _) = do - throwTo t AsyncCancelled - void (waitCatch a) + throwTo t AsyncCancelled + void (waitCatch a) -- | The exception thrown by `cancel` to terminate a thread. data AsyncCancelled = AsyncCancelled - deriving (Show, Eq - , Typeable + deriving + ( Show + , Eq ) instance Exception AsyncCancelled where -#if MIN_VERSION_base(4,7,0) -- wraps in SomeAsyncException -- See https://github.com/ghc/ghc/commit/756a970eacbb6a19230ee3ba57e24999e4157b09 fromException = asyncExceptionFromException toException = asyncExceptionToException -#endif -- | Cancel an asynchronous action -- diff --git a/src/Distribution/Compat/Binary.hs b/src/Distribution/Compat/Binary.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif - -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -module Distribution.Compat.Binary - ( decodeOrFailIO - , decodeFileOrFail' -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - , module Data.Binary -#else - , Binary(..) - , decode, encode, encodeFile -#endif - ) where - -import Control.Exception (ErrorCall (..), catch, evaluate) -import Data.ByteString.Lazy (ByteString) - -#if __GLASGOW_HASKELL__ >= 708 || MIN_VERSION_binary(0,7,0) - -import Data.Binary - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f - -#else - -import Data.Binary.Get -import Data.Binary.Put -import qualified Data.ByteString.Lazy as BSL - -import Distribution.Compat.Binary.Class -import Distribution.Compat.Binary.Generic () - --- | Decode a value from a lazy ByteString, reconstructing the --- original structure. --- -decode :: Binary a => ByteString -> a -decode = runGet get - --- | Encode a value using binary serialisation to a lazy ByteString. --- -encode :: Binary a => a -> ByteString -encode = runPut . put -{-# INLINE encode #-} - --- | Lazily reconstruct a value previously written to a file. -decodeFileOrFail' :: Binary a => FilePath -> IO (Either String a) -decodeFileOrFail' f = decodeOrFailIO =<< BSL.readFile f - --- | Lazily serialise a value to a file -encodeFile :: Binary a => FilePath -> a -> IO () -encodeFile f = BSL.writeFile f . encode - -#endif - -decodeOrFailIO :: Binary a => ByteString -> IO (Either String a) -decodeOrFailIO bs = - catch (evaluate (decode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif diff --git a/src/Distribution/Compat/Binary/Class.hs b/src/Distribution/Compat/Binary/Class.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary/Class.hs +++ /dev/null @@ -1,519 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE DefaultSignatures #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Binary.Class --- Copyright : Lennart Kolmodin --- License : BSD3-style (see LICENSE) --- --- Maintainer : Lennart Kolmodin --- Stability : unstable --- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances --- --- Typeclass and instances for binary serialization. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Binary.Class ( - - -- * The Binary class - Binary(..) - - -- * Support for generics - , GBinary(..) - - ) where - -import Data.Word - -import Data.Binary.Put -import Data.Binary.Get - -import Control.Applicative ((<$>), (<*>), (*>)) -import Foreign - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as L - -import Data.Char (chr,ord) -import Data.List (unfoldr) -import Data.Foldable (traverse_) - --- And needed for the instances: -import qualified Data.ByteString as B -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import qualified Data.Ratio as R - -import qualified Data.Tree as T - -import Data.Array.Unboxed - -import GHC.Generics - -import qualified Data.Sequence as Seq -import qualified Data.Foldable as Fold - ------------------------------------------------------------------------- - -class GBinary f where - gput :: f t -> Put - gget :: Get (f t) - --- | The 'Binary' class provides 'put' and 'get', methods to encode and --- decode a Haskell value to a lazy 'ByteString'. It mirrors the 'Read' and --- 'Show' classes for textual representation of Haskell types, and is --- suitable for serialising Haskell values to disk, over the network. --- --- For decoding and generating simple external binary formats (e.g. C --- structures), Binary may be used, but in general is not suitable --- for complex protocols. Instead use the 'Put' and 'Get' primitives --- directly. --- --- Instances of Binary should satisfy the following property: --- --- > decode . encode == id --- --- That is, the 'get' and 'put' methods should be the inverse of each --- other. A range of instances are provided for basic Haskell types. --- -class Binary t where - -- | Encode a value in the Put monad. - put :: t -> Put - -- | Decode a value in the Get monad - get :: Get t - - default put :: (Generic t, GBinary (Rep t)) => t -> Put - put = gput . from - - default get :: (Generic t, GBinary (Rep t)) => Get t - get = to `fmap` gget - ------------------------------------------------------------------------- --- Simple instances - --- The () type need never be written to disk: values of singleton type --- can be reconstructed from the type alone -instance Binary () where - put () = return () - get = return () - --- Bools are encoded as a byte in the range 0 .. 1 -instance Binary Bool where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - --- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 -instance Binary Ordering where - put = putWord8 . fromIntegral . fromEnum - get = fmap (toEnum . fromIntegral) getWord8 - ------------------------------------------------------------------------- --- Words and Ints - --- Words8s are written as bytes -instance Binary Word8 where - put = putWord8 - get = getWord8 - --- Words16s are written as 2 bytes in big-endian (network) order -instance Binary Word16 where - put = putWord16be - get = getWord16be - --- Words32s are written as 4 bytes in big-endian (network) order -instance Binary Word32 where - put = putWord32be - get = getWord32be - --- Words64s are written as 8 bytes in big-endian (network) order -instance Binary Word64 where - put = putWord64be - get = getWord64be - --- Int8s are written as a single byte. -instance Binary Int8 where - put i = put (fromIntegral i :: Word8) - get = fmap fromIntegral (get :: Get Word8) - --- Int16s are written as a 2 bytes in big endian format -instance Binary Int16 where - put i = put (fromIntegral i :: Word16) - get = fmap fromIntegral (get :: Get Word16) - --- Int32s are written as a 4 bytes in big endian format -instance Binary Int32 where - put i = put (fromIntegral i :: Word32) - get = fmap fromIntegral (get :: Get Word32) - --- Int64s are written as a 4 bytes in big endian format -instance Binary Int64 where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - ------------------------------------------------------------------------- - --- Words are are written as Word64s, that is, 8 bytes in big endian format -instance Binary Word where - put i = put (fromIntegral i :: Word64) - get = fmap fromIntegral (get :: Get Word64) - --- Ints are are written as Int64s, that is, 8 bytes in big endian format -instance Binary Int where - put i = put (fromIntegral i :: Int64) - get = fmap fromIntegral (get :: Get Int64) - ------------------------------------------------------------------------- --- --- Portable, and pretty efficient, serialisation of Integer --- - --- Fixed-size type for a subset of Integer -type SmallInt = Int32 - --- Integers are encoded in two ways: if they fit inside a SmallInt, --- they're written as a byte tag, and that value. If the Integer value --- is too large to fit in a SmallInt, it is written as a byte array, --- along with a sign and length field. - -instance Binary Integer where - - {-# INLINE put #-} - put n | n >= lo && n <= hi = do - putWord8 0 - put (fromIntegral n :: SmallInt) -- fast path - where - lo = fromIntegral (minBound :: SmallInt) :: Integer - hi = fromIntegral (maxBound :: SmallInt) :: Integer - - put n = do - putWord8 1 - put sign - put (unroll (abs n)) -- unroll the bytes - where - sign = fromIntegral (signum n) :: Word8 - - {-# INLINE get #-} - get = do - tag <- get :: Get Word8 - case tag of - 0 -> fmap fromIntegral (get :: Get SmallInt) - _ -> do sign <- get - bytes <- get - let v = roll bytes - return $! if sign == (1 :: Word8) then v else - v - --- --- Fold and unfold an Integer to and from a list of its bytes --- -unroll :: Integer -> [Word8] -unroll = unfoldr step - where - step 0 = Nothing - step i = Just (fromIntegral i, i `shiftR` 8) - -roll :: [Word8] -> Integer -roll = foldr unstep 0 - where - unstep b a = a `shiftL` 8 .|. fromIntegral b - -{- - --- --- An efficient, raw serialisation for Integer (GHC only) --- - --- TODO This instance is not architecture portable. GMP stores numbers as --- arrays of machine sized words, so the byte format is not portable across --- architectures with different endianness and word size. - -import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) -import GHC.Base hiding (ord, chr) -import GHC.Prim -import GHC.Ptr (Ptr(..)) -import GHC.IOBase (IO(..)) - -instance Binary Integer where - put (S# i) = putWord8 0 *> put (I# i) - put (J# s ba) = do - putWord8 1 - put (I# s) - put (BA ba) - - get = do - b <- getWord8 - case b of - 0 -> do (I# i#) <- get - return (S# i#) - _ -> do (I# s#) <- get - (BA a#) <- get - return (J# s# a#) - -instance Binary ByteArray where - - -- Pretty safe. - put (BA ba) = - let sz = sizeofByteArray# ba -- (primitive) in *bytes* - addr = byteArrayContents# ba - bs = unsafePackAddress (I# sz) addr - in put bs -- write as a ByteString. easy, yay! - - -- Pretty scary. Should be quick though - get = do - (fp, off, n@(I# sz)) <- fmap toForeignPtr get -- so decode a ByteString - assert (off == 0) $ return $ unsafePerformIO $ do - (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# - let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? - withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) - freezeByteArray arr - --- wrapper for ByteArray# -data ByteArray = BA {-# UNPACK #-} !ByteArray# -data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newPinnedByteArray# sz s of { (# s', arr #) -> - (# s', MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> - (# s', BA arr' #) } - --} - -instance (Binary a,Integral a) => Binary (R.Ratio a) where - put r = put (R.numerator r) *> put (R.denominator r) - get = (R.%) <$> get <*> get - ------------------------------------------------------------------------- - --- Char is serialised as UTF-8 -instance Binary Char where - put a | c <= 0x7f = put (fromIntegral c :: Word8) - | c <= 0x7ff = do put (0xc0 .|. y) - put (0x80 .|. z) - | c <= 0xffff = do put (0xe0 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | c <= 0x10ffff = do put (0xf0 .|. w) - put (0x80 .|. x) - put (0x80 .|. y) - put (0x80 .|. z) - | otherwise = error "Not a valid Unicode code point" - where - c = ord a - z, y, x, w :: Word8 - z = fromIntegral (c .&. 0x3f) - y = fromIntegral (shiftR c 6 .&. 0x3f) - x = fromIntegral (shiftR c 12 .&. 0x3f) - w = fromIntegral (shiftR c 18 .&. 0x7) - - get = do - let getByte = fmap (fromIntegral :: Word8 -> Int) get - shiftL6 = flip shiftL 6 :: Int -> Int - w <- getByte - r <- case () of - _ | w < 0x80 -> return w - | w < 0xe0 -> do - x <- fmap (xor 0x80) getByte - return (x .|. shiftL6 (xor 0xc0 w)) - | w < 0xf0 -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - return (y .|. shiftL6 (x .|. shiftL6 - (xor 0xe0 w))) - | otherwise -> do - x <- fmap (xor 0x80) getByte - y <- fmap (xor 0x80) getByte - z <- fmap (xor 0x80) getByte - return (z .|. shiftL6 (y .|. shiftL6 - (x .|. shiftL6 (xor 0xf0 w)))) - return $! chr r - ------------------------------------------------------------------------- --- Instances for the first few tuples - -instance (Binary a, Binary b) => Binary (a,b) where - put (a,b) = put a *> put b - get = (,) <$> get <*> get - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put (a,b,c) = put a *> put b *> put c - get = (,,) <$> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put (a,b,c,d) = put a *> put b *> put c *> put d - get = (,,,) <$> get <*> get <*> get <*> get - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put (a,b,c,d,e) = put a *> put b *> put c *> put d *> put e - get = (,,,,) <$> get <*> get <*> get <*> get <*> get - --- --- and now just recurse: --- - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) - => Binary (a,b,c,d,e,f) where - put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) - get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) - => Binary (a,b,c,d,e,f,g) where - put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) - get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h) - => Binary (a,b,c,d,e,f,g,h) where - put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) - get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i) - => Binary (a,b,c,d,e,f,g,h,i) where - put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) - get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, - Binary f, Binary g, Binary h, Binary i, Binary j) - => Binary (a,b,c,d,e,f,g,h,i,j) where - put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) - get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) - ------------------------------------------------------------------------- --- Container types - -instance Binary a => Binary [a] where - put l = put (length l) *> traverse_ put l - get = do n <- get :: Get Int - getMany n - --- | 'getMany n' get 'n' elements in order, without blowing the stack. -getMany :: Binary a => Int -> Get [a] -getMany n = go [] n - where - go xs 0 = return $! reverse xs - go xs i = do x <- get - -- we must seq x to avoid stack overflows due to laziness in - -- (>>=) - x `seq` go (x:xs) (i-1) -{-# INLINE getMany #-} - -instance (Binary a) => Binary (Maybe a) where - put Nothing = putWord8 0 - put (Just x) = putWord8 1 *> put x - get = do - w <- getWord8 - case w of - 0 -> return Nothing - _ -> fmap Just get - -instance (Binary a, Binary b) => Binary (Either a b) where - put (Left a) = putWord8 0 *> put a - put (Right b) = putWord8 1 *> put b - get = do - w <- getWord8 - case w of - 0 -> fmap Left get - _ -> fmap Right get - ------------------------------------------------------------------------- --- ByteStrings (have specially efficient instances) - -instance Binary B.ByteString where - put bs = do put (B.length bs) - putByteString bs - get = get >>= getByteString - --- --- Using old versions of fps, this is a type synonym, and non portable --- --- Requires 'flexible instances' --- -instance Binary ByteString where - put bs = do put (fromIntegral (L.length bs) :: Int) - putLazyByteString bs - get = get >>= getLazyByteString - ------------------------------------------------------------------------- --- Maps and Sets - -instance (Binary a) => Binary (Set.Set a) where - put s = put (Set.size s) *> traverse_ put (Set.toAscList s) - get = fmap Set.fromDistinctAscList get - -instance (Binary k, Binary e) => Binary (Map.Map k e) where - put m = put (Map.size m) *> traverse_ put (Map.toAscList m) - get = fmap Map.fromDistinctAscList get - -instance Binary IntSet.IntSet where - put s = put (IntSet.size s) *> traverse_ put (IntSet.toAscList s) - get = fmap IntSet.fromDistinctAscList get - -instance (Binary e) => Binary (IntMap.IntMap e) where - put m = put (IntMap.size m) *> traverse_ put (IntMap.toAscList m) - get = fmap IntMap.fromDistinctAscList get - ------------------------------------------------------------------------- --- Queues and Sequences - -instance (Binary e) => Binary (Seq.Seq e) where - put s = put (Seq.length s) *> Fold.traverse_ put s - get = do n <- get :: Get Int - rep Seq.empty n get - where rep xs 0 _ = return $! xs - rep xs n g = xs `seq` n `seq` do - x <- g - rep (xs Seq.|> x) (n-1) g - ------------------------------------------------------------------------- --- Floating point - -instance Binary Double where - put d = put (decodeFloat d) - get = encodeFloat <$> get <*> get - -instance Binary Float where - put f = put (decodeFloat f) - get = encodeFloat <$> get <*> get - ------------------------------------------------------------------------- --- Trees - -instance (Binary e) => Binary (T.Tree e) where - put (T.Node r s) = put r *> put s - get = T.Node <$> get <*> get - ------------------------------------------------------------------------- --- Arrays - -instance (Binary i, Ix i, Binary e) => Binary (Array i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- write the length - traverse_ put (elems a) -- now the elems. - get = do - bs <- get - n <- get -- read the length - xs <- getMany n -- now the elems. - return (listArray bs xs) - --- --- The IArray UArray e constraint is non portable. Requires flexible instances --- -instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where - put a = do - put (bounds a) - put (rangeSize $ bounds a) -- now write the length - traverse_ put (elems a) - get = do - bs <- get - n <- get - xs <- getMany n - return (listArray bs xs) diff --git a/src/Distribution/Compat/Binary/Generic.hs b/src/Distribution/Compat/Binary/Generic.hs deleted file mode 100644 --- a/src/Distribution/Compat/Binary/Generic.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Distribution/Compat/CharParsing.hs b/src/Distribution/Compat/CharParsing.hs deleted file mode 100644 --- a/src/Distribution/Compat/CharParsing.hs +++ /dev/null @@ -1,357 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.CharParsing --- Copyright : (c) Edward Kmett 2011 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Parsers for character streams --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.CharParsing - ( - -- * Combinators - oneOf -- :: CharParsing m => [Char] -> m Char - , noneOf -- :: CharParsing m => [Char] -> m Char - , spaces -- :: CharParsing m => m () - , space -- :: CharParsing m => m Char - , newline -- :: CharParsing m => m Char - , tab -- :: CharParsing m => m Char - , upper -- :: CharParsing m => m Char - , lower -- :: CharParsing m => m Char - , alphaNum -- :: CharParsing m => m Char - , letter -- :: CharParsing m => m Char - , digit -- :: CharParsing m => m Char - , hexDigit -- :: CharParsing m => m Char - , octDigit -- :: CharParsing m => m Char - , satisfyRange -- :: CharParsing m => Char -> Char -> m Char - -- * Class - , CharParsing(..) - -- * Cabal additions - , integral - , signedIntegral - , munch1 - , munch - , skipSpaces1 - , module Distribution.Compat.Parsing - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Char -import Data.Text (Text, unpack) - -import qualified Text.Parsec as Parsec - -import Distribution.Compat.Parsing - --- | @oneOf cs@ succeeds if the current character is in the supplied --- list of characters @cs@. Returns the parsed character. See also --- 'satisfy'. --- --- > vowel = oneOf "aeiou" -oneOf :: CharParsing m => [Char] -> m Char -oneOf xs = satisfy (\c -> c `elem` xs) -{-# INLINE oneOf #-} - --- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current --- character is /not/ in the supplied list of characters @cs@. Returns the --- parsed character. --- --- > consonant = noneOf "aeiou" -noneOf :: CharParsing m => [Char] -> m Char -noneOf xs = satisfy (\c -> c `notElem` xs) -{-# INLINE noneOf #-} - --- | Skips /zero/ or more white space characters. See also 'skipMany'. -spaces :: CharParsing m => m () -spaces = skipMany space "white space" -{-# INLINE spaces #-} - --- | Parses a white space character (any character which satisfies 'isSpace') --- Returns the parsed character. -space :: CharParsing m => m Char -space = satisfy isSpace "space" -{-# INLINE space #-} - --- | Parses a newline character (\'\\n\'). Returns a newline character. -newline :: CharParsing m => m Char -newline = char '\n' "new-line" -{-# INLINE newline #-} - --- | Parses a tab character (\'\\t\'). Returns a tab character. -tab :: CharParsing m => m Char -tab = char '\t' "tab" -{-# INLINE tab #-} - --- | Parses an upper case letter. Returns the parsed character. -upper :: CharParsing m => m Char -upper = satisfy isUpper "uppercase letter" -{-# INLINE upper #-} - --- | Parses a lower case character. Returns the parsed character. -lower :: CharParsing m => m Char -lower = satisfy isLower "lowercase letter" -{-# INLINE lower #-} - --- | Parses a letter or digit. Returns the parsed character. -alphaNum :: CharParsing m => m Char -alphaNum = satisfy isAlphaNum "letter or digit" -{-# INLINE alphaNum #-} - --- | Parses a letter (an upper case or lower case character). Returns the --- parsed character. -letter :: CharParsing m => m Char -letter = satisfy isAlpha "letter" -{-# INLINE letter #-} - --- | Parses a digit. Returns the parsed character. -digit :: CharParsing m => m Char -digit = satisfy isDigit "digit" -{-# INLINE digit #-} - --- | Parses a hexadecimal digit (a digit or a letter between \'a\' and --- \'f\' or \'A\' and \'F\'). Returns the parsed character. -hexDigit :: CharParsing m => m Char -hexDigit = satisfy isHexDigit "hexadecimal digit" -{-# INLINE hexDigit #-} - --- | Parses an octal digit (a character between \'0\' and \'7\'). Returns --- the parsed character. -octDigit :: CharParsing m => m Char -octDigit = satisfy isOctDigit "octal digit" -{-# INLINE octDigit #-} - -satisfyRange :: CharParsing m => Char -> Char -> m Char -satisfyRange a z = satisfy (\c -> c >= a && c <= z) -{-# INLINE satisfyRange #-} - --- | Additional functionality needed to parse character streams. -class Parsing m => CharParsing m where - -- | Parse a single character of the input, with UTF-8 decoding - satisfy :: (Char -> Bool) -> m Char - - -- | @char c@ parses a single character @c@. Returns the parsed - -- character (i.e. @c@). - -- - -- /e.g./ - -- - -- @semiColon = 'char' ';'@ - char :: Char -> m Char - char c = satisfy (c ==) show [c] - {-# INLINE char #-} - - -- | @notChar c@ parses any single character other than @c@. Returns the parsed - -- character. - notChar :: Char -> m Char - notChar c = satisfy (c /=) - {-# INLINE notChar #-} - - -- | This parser succeeds for any character. Returns the parsed character. - anyChar :: m Char - anyChar = satisfy (const True) - {-# INLINE anyChar #-} - - -- | @string s@ parses a sequence of characters given by @s@. Returns - -- the parsed string (i.e. @s@). - -- - -- > divOrMod = string "div" - -- > <|> string "mod" - string :: String -> m String - string s = s <$ try (traverse_ char s) show s - {-# INLINE string #-} - - -- | @text t@ parses a sequence of characters determined by the text @t@ Returns - -- the parsed text fragment (i.e. @t@). - -- - -- Using @OverloadedStrings@: - -- - -- > divOrMod = text "div" - -- > <|> text "mod" - text :: Text -> m Text - text t = t <$ string (unpack t) - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where - satisfy = lift . satisfy - {-# INLINE satisfy #-} - char = lift . char - {-# INLINE char #-} - notChar = lift . notChar - {-# INLINE notChar #-} - anyChar = lift anyChar - {-# INLINE anyChar #-} - string = lift . string - {-# INLINE string #-} - text = lift . text - {-# INLINE text #-} - -instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where - satisfy = Parsec.satisfy - char = Parsec.char - notChar c = Parsec.satisfy (/= c) - anyChar = Parsec.anyChar - string = Parsec.string - -------------------------------------------------------------------------------- --- Our additions -------------------------------------------------------------------------------- - -integral :: (CharParsing m, Integral a) => m a -integral = toNumber <$> some d "integral" - where - toNumber = foldl' (\a b -> a * 10 + b) 0 - d = f <$> satisfyRange '0' '9' - f '0' = 0 - f '1' = 1 - f '2' = 2 - f '3' = 3 - f '4' = 4 - f '5' = 5 - f '6' = 6 - f '7' = 7 - f '8' = 8 - f '9' = 9 - f _ = error "panic! integral" -{-# INLINE integral #-} - --- | Accepts negative (starting with @-@) and positive (without sign) integral --- numbers. --- --- @since 3.4.0.0 -signedIntegral :: (CharParsing m, Integral a) => m a -signedIntegral = negate <$ char '-' <*> integral <|> integral -{-# INLINE signedIntegral #-} - --- | Greedily munch characters while predicate holds. --- Require at least one character. -munch1 :: CharParsing m => (Char -> Bool) -> m String -munch1 = some . satisfy -{-# INLINE munch1 #-} - --- | Greedely munch characters while predicate holds. --- Always succeeds. -munch :: CharParsing m => (Char -> Bool) -> m String -munch = many . satisfy -{-# INLINE munch #-} - -skipSpaces1 :: CharParsing m => m () -skipSpaces1 = skipSome space -{-# INLINE skipSpaces1 #-} diff --git a/src/Distribution/Compat/CopyFile.hs b/src/Distribution/Compat/CopyFile.hs --- a/src/Distribution/Compat/CopyFile.hs +++ b/src/Distribution/Compat/CopyFile.hs @@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.CopyFile ( - copyFile, - copyFileChanged, - filesEqual, - copyOrdinaryFile, - copyExecutableFile, - setFileOrdinary, - setFileExecutable, - setDirOrdinary, + +module Distribution.Compat.CopyFile + ( copyFile + , copyFileChanged + , filesEqual + , copyOrdinaryFile + , copyExecutableFile + , setFileOrdinary + , setFileExecutable + , setDirOrdinary ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifndef mingw32_HOST_OS import Distribution.Compat.Internal.TempFile @@ -20,6 +21,8 @@ import Control.Exception ( bracketOnError ) import qualified Data.ByteString.Lazy as BSL +import Data.Bits + ( (.|.) ) import System.IO.Error ( ioeSetLocation ) import System.Directory @@ -34,10 +37,8 @@ import System.Posix.Types ( FileMode ) -import System.Posix.Internals - ( c_chmod, withFilePath ) -import Foreign.C - ( throwErrnoPathIfMinus1_ ) +import System.Posix.Files + ( getFileStatus, fileMode, setFileMode ) #else /* else mingw32_HOST_OS */ @@ -66,18 +67,20 @@ #endif /* mingw32_HOST_OS */ copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () -copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest -setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () #ifndef mingw32_HOST_OS -setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- -setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x +-- When running with a restrictive UMASK such as 0077 we still want to +-- install files and directories that are accessible to other users. +setFileOrdinary path = addFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = addFileMode path 0o755 -- file perms -rwxr-xr-x -setFileMode :: FilePath -> FileMode -> IO () -setFileMode name m = - withFilePath name $ \s -> do - throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +addFileMode :: FilePath -> FileMode -> IO () +addFileMode name m = do + o <- fileMode <$> getFileStatus name + setFileMode name (m .|. o) #else setFileOrdinary _ = return () setFileExecutable _ = return () @@ -91,7 +94,7 @@ copyFile fromFPath toFPath = copy `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile")) - where + where #ifndef mingw32_HOST_OS copy = withBinaryFile fromFPath ReadMode $ \hFrom -> bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> @@ -237,8 +240,9 @@ filesEqual f1 f2 = do ex1 <- doesFileExist f1 ex2 <- doesFileExist f2 - if not (ex1 && ex2) then return False else - withBinaryFile f1 ReadMode $ \h1 -> + if not (ex1 && ex2) + then return False + else withBinaryFile f1 ReadMode $ \h1 -> withBinaryFile f2 ReadMode $ \h2 -> do s1 <- hFileSize h1 s2 <- hFileSize h2 diff --git a/src/Distribution/Compat/CreatePipe.hs b/src/Distribution/Compat/CreatePipe.hs --- a/src/Distribution/Compat/CreatePipe.hs +++ b/src/Distribution/Compat/CreatePipe.hs @@ -1,81 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Compat.CreatePipe (createPipe) where +module Distribution.Compat.CreatePipe + {-# DEPRECATED "Use System.Process from package process directly" #-} + (createPipe) where -#if MIN_VERSION_process(1,2,1) import System.Process (createPipe) -#else -import System.IO (Handle, hSetBinaryMode) - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -import qualified Prelude -import Control.Exception (onException) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt(..), CUInt(..)) -import Foreign.Ptr (Ptr) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Storable (peek, peekElemOff) -import GHC.IO.FD (mkFD) -import GHC.IO.Device (IODeviceType(Stream)) -import GHC.IO.Handle.FD (mkHandleFromFD) -import System.IO (IOMode(ReadMode, WriteMode)) -#elif defined ghcjs_HOST_OS -#else -import System.Posix.IO (fdToHandle) -import qualified System.Posix.IO as Posix -#endif - -createPipe :: IO (Handle, Handle) --- The mingw32_HOST_OS CPP macro is GHC-specific -#ifdef mingw32_HOST_OS -createPipe = do - (readfd, writefd) <- allocaArray 2 $ \ pfds -> do - throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 ({- _O_BINARY -} 32768) - readfd <- peek pfds - writefd <- peekElemOff pfds 1 - return (readfd, writefd) - (do readh <- fdToHandle readfd ReadMode - writeh <- fdToHandle writefd WriteMode - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh)) `onException` (close readfd >> close writefd) - where - fdToHandle :: CInt -> IOMode -> IO Handle - fdToHandle fd mode = do - (fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False - mkHandleFromFD fd' deviceType "" mode False Nothing - - close :: CInt -> IO () - close = throwErrnoIfMinus1_ "_close" . c__close - where _ = callStack -- TODO: attach call stack to exception - - _ = callStack -- TODO: attach call stack to exceptions - -foreign import ccall "io.h _pipe" c__pipe :: - Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt - -foreign import ccall "io.h _close" c__close :: - CInt -> Prelude.IO CInt -#elif defined ghcjs_HOST_OS -createPipe = error "createPipe" - where - _ = callStack -#else -createPipe = do - (readfd, writefd) <- Posix.createPipe - readh <- fdToHandle readfd - writeh <- fdToHandle writefd - hSetBinaryMode readh True - hSetBinaryMode writeh True - return (readh, writeh) - where - _ = callStack -#endif -#endif diff --git a/src/Distribution/Compat/DList.hs b/src/Distribution/Compat/DList.hs deleted file mode 100644 --- a/src/Distribution/Compat/DList.hs +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.DList --- Copyright : (c) Ben Gamari 2015-2019 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A very simple difference list. -module Distribution.Compat.DList ( - DList, - runDList, - empty, - singleton, - fromList, - toList, - snoc, -) where - -import Prelude () -import Distribution.Compat.Prelude hiding (toList, empty) - --- | Difference list. -newtype DList a = DList ([a] -> [a]) - -runDList :: DList a -> [a] -runDList (DList run) = run [] - --- | Make 'DList' containing single element. -singleton :: a -> DList a -singleton a = DList (a:) - --- | @since 3.4.0.0 -empty :: DList a -empty = DList id - -fromList :: [a] -> DList a -fromList as = DList (as ++) - -toList :: DList a -> [a] -toList = runDList - -snoc :: DList a -> a -> DList a -snoc xs x = xs <> singleton x - -instance Monoid (DList a) where - mempty = empty - mappend = (<>) - -instance Semigroup (DList a) where - DList a <> DList b = DList (a . b) diff --git a/src/Distribution/Compat/Directory.hs b/src/Distribution/Compat/Directory.hs --- a/src/Distribution/Compat/Directory.hs +++ b/src/Distribution/Compat/Directory.hs @@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module Distribution.Compat.Directory -( listDirectory -, makeAbsolute -, doesPathExist -) where + ( listDirectory + , makeAbsolute + , doesPathExist + ) where #if MIN_VERSION_directory(1,2,7) import System.Directory as Dir hiding (doesPathExist) @@ -46,4 +46,3 @@ else doesFileExist path #endif - diff --git a/src/Distribution/Compat/Environment.hs b/src/Distribution/Compat/Environment.hs --- a/src/Distribution/Compat/Environment.hs +++ b/src/Distribution/Compat/Environment.hs @@ -3,33 +3,20 @@ {-# LANGUAGE RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Environment - ( getEnvironment, lookupEnv, setEnv, unsetEnv ) - where +module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv) +where +import Distribution.Compat.Prelude import Prelude () import qualified Prelude -import Distribution.Compat.Prelude -#ifndef mingw32_HOST_OS -#if __GLASGOW_HASKELL__ < 708 -import Foreign.C.Error (throwErrnoIf_) -#endif -#endif - +import System.Environment (lookupEnv, unsetEnv) import qualified System.Environment as System -import System.Environment (lookupEnv) -#if __GLASGOW_HASKELL__ >= 708 -import System.Environment (unsetEnv) -#endif import Distribution.Compat.Stack #ifdef mingw32_HOST_OS import Foreign.C -#if __GLASGOW_HASKELL__ < 708 -import Foreign.Ptr (nullPtr) -#endif import GHC.Windows #else import Foreign.C.Types @@ -73,9 +60,10 @@ where _ = callStack -- TODO: attach CallStack to exception +{- FOURMOLU_DISABLE -} # if defined(i386_HOST_ARCH) # define WINDOWS_CCONV stdcall -# elif defined(x86_64_HOST_ARCH) +# elif defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) # define WINDOWS_CCONV ccall # else # error Unknown mingw32 arch @@ -95,40 +83,4 @@ foreign import ccall unsafe "setenv" c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt #endif /* mingw32_HOST_OS */ - -#if __GLASGOW_HASKELL__ < 708 - --- | @unsetEnv name@ removes the specified environment variable from the --- environment of the current process. --- --- Throws `Control.Exception.IOException` if @name@ is the empty string or --- contains an equals sign. --- --- @since 4.7.0.0 -unsetEnv :: String -> IO () -#ifdef mingw32_HOST_OS -unsetEnv key = withCWString key $ \k -> do - success <- c_SetEnvironmentVariable k nullPtr - unless success $ do - -- We consider unsetting an environment variable that does not exist not as - -- an error, hence we ignore eRROR_ENVVAR_NOT_FOUND. - err <- c_GetLastError - unless (err == eRROR_ENVVAR_NOT_FOUND) $ do - throwGetLastError "unsetEnv" - -eRROR_ENVVAR_NOT_FOUND :: DWORD -eRROR_ENVVAR_NOT_FOUND = 203 - -foreign import WINDOWS_CCONV unsafe "windows.h GetLastError" - c_GetLastError:: IO DWORD -#else -unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv) -#if __GLASGOW_HASKELL__ > 706 -foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#else --- HACK: We hope very hard that !UNSETENV_RETURNS_VOID -foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt -#endif -#endif - -#endif +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Compat/Exception.hs b/src/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/src/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE CPP #-} -module Distribution.Compat.Exception ( - catchIO, - catchExit, - tryIO, - displayException, - ) where - -#ifdef MIN_VERSION_base -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#else -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#endif - -import System.Exit -import qualified Control.Exception as Exception - -#if MINVER_base_48 -import Control.Exception (displayException) -#endif - --- | Try 'IOException'. -tryIO :: IO a -> IO (Either Exception.IOException a) -tryIO = Exception.try - --- | Catch 'IOException'. -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -catchIO = Exception.catch - --- | Catch 'ExitCode' -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -catchExit = Exception.catch - -#if !MINVER_base_48 -displayException :: Exception.Exception e => e -> String -displayException = show -#endif diff --git a/src/Distribution/Compat/FilePath.hs b/src/Distribution/Compat/FilePath.hs --- a/src/Distribution/Compat/FilePath.hs +++ b/src/Distribution/Compat/FilePath.hs @@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} module Distribution.Compat.FilePath -( isExtensionOf -, stripExtension -) where + ( isExtensionOf + , stripExtension + ) where -import Data.List ( isSuffixOf, stripPrefix ) +import Data.List (isSuffixOf, stripPrefix) import System.FilePath #if !MIN_VERSION_filepath(1,4,2) diff --git a/src/Distribution/Compat/GetShortPathName.hs b/src/Distribution/Compat/GetShortPathName.hs --- a/src/Distribution/Compat/GetShortPathName.hs +++ b/src/Distribution/Compat/GetShortPathName.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.GetShortPathName -- @@ -8,12 +9,11 @@ -- Portability : Windows-only -- -- Win32 API 'GetShortPathName' function. - -module Distribution.Compat.GetShortPathName ( getShortPathName ) - where +module Distribution.Compat.GetShortPathName (getShortPathName) +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () #ifdef mingw32_HOST_OS @@ -22,7 +22,8 @@ import System.Win32 (LPCTSTR, LPTSTR, DWORD) import Foreign.Marshal.Array (allocaArray) -#ifdef x86_64_HOST_ARCH +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define WINAPI ccall #else #define WINAPI stdcall @@ -57,3 +58,4 @@ getShortPathName path = return path #endif +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Compat/Graph.hs b/src/Distribution/Compat/Graph.hs deleted file mode 100644 --- a/src/Distribution/Compat/Graph.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Graph --- Copyright : (c) Edward Z. Yang 2016 --- License : BSD3 --- --- Maintainer : cabal-dev@haskell.org --- Stability : experimental --- Portability : portable --- --- A data type representing directed graphs, backed by "Data.Graph". --- It is strict in the node type. --- --- This is an alternative interface to "Data.Graph". In this interface, --- nodes (identified by the 'IsNode' type class) are associated with a --- key and record the keys of their neighbors. This interface is more --- convenient than 'Data.Graph.Graph', which requires vertices to be --- explicitly handled by integer indexes. --- --- The current implementation has somewhat peculiar performance --- characteristics. The asymptotics of all map-like operations mirror --- their counterparts in "Data.Map". However, to perform a graph --- operation, we first must build the "Data.Graph" representation, an --- operation that takes /O(V + E log V)/. However, this operation can --- be amortized across all queries on that particular graph. --- --- Some nodes may be broken, i.e., refer to neighbors which are not --- stored in the graph. In our graph algorithms, we transparently --- ignore such edges; however, you can easily query for the broken --- vertices of a graph using 'broken' (and should, e.g., to ensure that --- a closure of a graph is well-formed.) It's possible to take a closed --- subset of a broken graph and get a well-formed graph. --- ------------------------------------------------------------------------------ - -module Distribution.Compat.Graph ( - -- * Graph type - Graph, - IsNode(..), - -- * Query - null, - size, - member, - lookup, - -- * Construction - empty, - insert, - deleteKey, - deleteLookup, - -- * Combine - unionLeft, - unionRight, - -- * Graph algorithms - stronglyConnComp, - SCC(..), - cycles, - broken, - neighbors, - revNeighbors, - closure, - revClosure, - topSort, - revTopSort, - -- * Conversions - -- ** Maps - toMap, - -- ** Lists - fromDistinctList, - toList, - keys, - -- ** Sets - keysSet, - -- ** Graphs - toGraph, - -- * Node type - Node(..), - nodeValue, -) where - -import Distribution.Compat.Prelude hiding (empty, lookup, null, toList) -import Prelude () - -import Data.Array ((!)) -import Data.Graph (SCC (..)) -import Distribution.Utils.Structured (Structure (..), Structured (..)) - -import qualified Data.Array as Array -import qualified Data.Foldable as Foldable -import qualified Data.Graph as G -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Data.Tree as Tree -import qualified Distribution.Compat.Prelude as Prelude - --- | A graph of nodes @a@. The nodes are expected to have instance --- of class 'IsNode'. -data Graph a - = Graph { - graphMap :: !(Map (Key a) a), - -- Lazily cached graph representation - graphForward :: G.Graph, - graphAdjoint :: G.Graph, - graphVertexToNode :: G.Vertex -> a, - graphKeyToVertex :: Key a -> Maybe G.Vertex, - graphBroken :: [(a, [Key a])] - } - deriving (Typeable) - --- NB: Not a Functor! (or Traversable), because you need --- to restrict Key a ~ Key b. We provide our own mapping --- functions. - --- General strategy is most operations are deferred to the --- Map representation. - -instance Show a => Show (Graph a) where - show = show . toList - -instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where - readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s) - -instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where - put x = put (toList x) - get = fmap fromDistinctList get - -instance Structured a => Structured (Graph a) where - structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)] - -instance (Eq (Key a), Eq a) => Eq (Graph a) where - g1 == g2 = graphMap g1 == graphMap g2 - -instance Foldable.Foldable Graph where - fold = Foldable.fold . graphMap - foldr f z = Foldable.foldr f z . graphMap - foldl f z = Foldable.foldl f z . graphMap - foldMap f = Foldable.foldMap f . graphMap - foldl' f z = Foldable.foldl' f z . graphMap - foldr' f z = Foldable.foldr' f z . graphMap -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,8,0) - length = Foldable.length . graphMap - null = Foldable.null . graphMap - toList = Foldable.toList . graphMap - elem x = Foldable.elem x . graphMap - maximum = Foldable.maximum . graphMap - minimum = Foldable.minimum . graphMap - sum = Foldable.sum . graphMap - product = Foldable.product . graphMap -#endif -#endif - -instance (NFData a, NFData (Key a)) => NFData (Graph a) where - rnf Graph { - graphMap = m, - graphForward = gf, - graphAdjoint = ga, - graphVertexToNode = vtn, - graphKeyToVertex = ktv, - graphBroken = b - } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m - --- TODO: Data instance? - --- | The 'IsNode' class is used for datatypes which represent directed --- graph nodes. A node of type @a@ is associated with some unique key of --- type @'Key' a@; given a node we can determine its key ('nodeKey') --- and the keys of its neighbors ('nodeNeighbors'). -class Ord (Key a) => IsNode a where - type Key a - nodeKey :: a -> Key a - nodeNeighbors :: a -> [Key a] - -instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where - type Key (Either a b) = Key a - nodeKey (Left x) = nodeKey x - nodeKey (Right x) = nodeKey x - nodeNeighbors (Left x) = nodeNeighbors x - nodeNeighbors (Right x) = nodeNeighbors x - --- | A simple, trivial data type which admits an 'IsNode' instance. -data Node k a = N a k [k] - deriving (Show, Eq) - --- | Get the value from a 'Node'. -nodeValue :: Node k a -> a -nodeValue (N a _ _) = a - -instance Functor (Node k) where - fmap f (N a k ks) = N (f a) k ks - -instance Ord k => IsNode (Node k a) where - type Key (Node k a) = k - nodeKey (N _ k _) = k - nodeNeighbors (N _ _ ks) = ks - --- TODO: Maybe introduce a typeclass for items which just --- keys (so, Key associated type, and nodeKey method). But --- I didn't need it here, so I didn't introduce it. - --- Query - --- | /O(1)/. Is the graph empty? -null :: Graph a -> Bool -null = Map.null . toMap - --- | /O(1)/. The number of nodes in the graph. -size :: Graph a -> Int -size = Map.size . toMap - --- | /O(log V)/. Check if the key is in the graph. -member :: IsNode a => Key a -> Graph a -> Bool -member k g = Map.member k (toMap g) - --- | /O(log V)/. Lookup the node at a key in the graph. -lookup :: IsNode a => Key a -> Graph a -> Maybe a -lookup k g = Map.lookup k (toMap g) - --- Construction - --- | /O(1)/. The empty graph. -empty :: IsNode a => Graph a -empty = fromMap Map.empty - --- | /O(log V)/. Insert a node into a graph. -insert :: IsNode a => a -> Graph a -> Graph a -insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g)) - --- | /O(log V)/. Delete the node at a key from the graph. -deleteKey :: IsNode a => Key a -> Graph a -> Graph a -deleteKey k g = fromMap (Map.delete k (toMap g)) - --- | /O(log V)/. Lookup and delete. This function returns the deleted --- value if it existed. -deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a) -deleteLookup k g = - let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g) - in (r, fromMap m') - --- Combining - --- | /O(V + V')/. Right-biased union, preferring entries --- from the second map when conflicts occur. --- @'nodeKey' x = 'nodeKey' (f x)@. -unionRight :: IsNode a => Graph a -> Graph a -> Graph a -unionRight g g' = fromMap (Map.union (toMap g') (toMap g)) - --- | /O(V + V')/. Left-biased union, preferring entries from --- the first map when conflicts occur. -unionLeft :: IsNode a => Graph a -> Graph a -> Graph a -unionLeft = flip unionRight - --- Graph-like operations - --- | /Ω(V + E)/. Compute the strongly connected components of a graph. --- Requires amortized construction of graph. -stronglyConnComp :: Graph a -> [SCC a] -stronglyConnComp g = map decode forest - where - forest = G.scc (graphForward g) - decode (Tree.Node v []) - | mentions_itself v = CyclicSCC [graphVertexToNode g v] - | otherwise = AcyclicSCC (graphVertexToNode g v) - decode other = CyclicSCC (dec other []) - where dec (Tree.Node v ts) vs - = graphVertexToNode g v : foldr dec vs ts - mentions_itself v = v `elem` (graphForward g ! v) --- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'. - --- | /Ω(V + E)/. Compute the cycles of a graph. --- Requires amortized construction of graph. -cycles :: Graph a -> [[a]] -cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ] - --- | /O(1)/. Return a list of nodes paired with their broken --- neighbors (i.e., neighbor keys which are not in the graph). --- Requires amortized construction of graph. -broken :: Graph a -> [(a, [Key a])] -broken g = graphBroken g - --- | Lookup the immediate neighbors from a key in the graph. --- Requires amortized construction of graph. -neighbors :: Graph a -> Key a -> Maybe [a] -neighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphForward g ! v)) - --- | Lookup the immediate reverse neighbors from a key in the graph. --- Requires amortized construction of graph. -revNeighbors :: Graph a -> Key a -> Maybe [a] -revNeighbors g k = do - v <- graphKeyToVertex g k - return (map (graphVertexToNode g) (graphAdjoint g ! v)) - --- | Compute the subgraph which is the closure of some set of keys. --- Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -closure :: Graph a -> [Key a] -> Maybe [a] -closure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphForward g) vs)) - --- | Compute the reverse closure of a graph from some set --- of keys. Returns @Nothing@ if one (or more) keys are not present in --- the graph. --- Requires amortized construction of graph. -revClosure :: Graph a -> [Key a] -> Maybe [a] -revClosure g ks = do - vs <- traverse (graphKeyToVertex g) ks - return (decodeVertexForest g (G.dfs (graphAdjoint g) vs)) - -flattenForest :: Tree.Forest a -> [a] -flattenForest = concatMap Tree.flatten - -decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a] -decodeVertexForest g = map (graphVertexToNode g) . flattenForest - --- | Topologically sort the nodes of a graph. --- Requires amortized construction of graph. -topSort :: Graph a -> [a] -topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g) - --- | Reverse topologically sort the nodes of a graph. --- Requires amortized construction of graph. -revTopSort :: Graph a -> [a] -revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g) - --- Conversions - --- | /O(1)/. Convert a map from keys to nodes into a graph. --- The map must satisfy the invariant that --- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@; --- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@ --- instead. The values of the map are assumed to already --- be in WHNF. -fromMap :: IsNode a => Map (Key a) a -> Graph a -fromMap m - = Graph { graphMap = m - -- These are lazily computed! - , graphForward = g - , graphAdjoint = G.transposeG g - , graphVertexToNode = vertex_to_node - , graphKeyToVertex = key_to_vertex - , graphBroken = broke - } - where - try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k) - - (brokenEdges, edges) - = unzip - $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n)) - | n <- ns ] - broke = filter (not . Prelude.null . snd) (zip ns brokenEdges) - - g = Array.listArray bounds edges - - ns = Map.elems m -- sorted ascending - vertices = zip (map nodeKey ns) [0..] - vertex_map = Map.fromAscList vertices - key_to_vertex k = Map.lookup k vertex_map - - vertex_to_node vertex = nodeTable ! vertex - - nodeTable = Array.listArray bounds ns - bounds = (0, Map.size m - 1) - --- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph. -fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a -fromDistinctList = fromMap - . Map.fromListWith (\_ -> duplicateError) - . map (\n -> n `seq` (nodeKey n, n)) - where - duplicateError n = error $ "Graph.fromDistinctList: duplicate key: " - ++ show (nodeKey n) - --- Map-like operations - --- | /O(V)/. Convert a graph into a list of nodes. -toList :: Graph a -> [a] -toList g = Map.elems (toMap g) - --- | /O(V)/. Convert a graph into a list of keys. -keys :: Graph a -> [Key a] -keys g = Map.keys (toMap g) - --- | /O(V)/. Convert a graph into a set of keys. -keysSet :: Graph a -> Set.Set (Key a) -keysSet g = Map.keysSet (toMap g) - --- | /O(1)/. Convert a graph into a map from keys to nodes. --- The resulting map @m@ is guaranteed to have the property that --- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@. -toMap :: Graph a -> Map (Key a) a -toMap = graphMap - --- Graph-like operations - --- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'. --- Requires amortized construction of graph. -toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex) -toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g) diff --git a/src/Distribution/Compat/Internal/TempFile.hs b/src/Distribution/Compat/Internal/TempFile.hs --- a/src/Distribution/Compat/Internal/TempFile.hs +++ b/src/Distribution/Compat/Internal/TempFile.hs @@ -1,30 +1,20 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_HADDOCK hide #-} -module Distribution.Compat.Internal.TempFile ( - openTempFile, - openBinaryTempFile, - openNewBinaryFile, - createTempDirectory, + +module Distribution.Compat.Internal.TempFile + ( openTempFile + , openBinaryTempFile + , openNewBinaryFile + , createTempDirectory ) where import Distribution.Compat.Exception -import System.FilePath (()) - -import System.IO (Handle, openTempFile, openBinaryTempFile) -#if defined(__IO_MANAGER_WINIO__) -import System.IO (openBinaryTempFileWithDefaultPermissions) -#else -import Control.Exception (onException) -import Data.Bits ((.|.)) -import Foreign.C (CInt, eEXIST, getErrno, errnoToIOError) -import GHC.IO.Handle.FD (fdToHandle) -import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath, - o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY) -#endif +import System.FilePath (()) +import System.IO (Handle, openBinaryTempFile, openBinaryTempFileWithDefaultPermissions, openTempFile) +import System.IO.Error (isAlreadyExistsError) import System.Posix.Internals (c_getpid) -import System.IO.Error (isAlreadyExistsError) #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) import System.Directory ( createDirectory ) @@ -32,89 +22,8 @@ import qualified System.Posix #endif --- ------------------------------------------------------------ --- * temporary files --- ------------------------------------------------------------ - --- This is here for Haskell implementations that do not come with --- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. --- TODO: This file should probably be removed. - --- This is a copy/paste of the openBinaryTempFile definition, but --- it uses 666 rather than 600 for the permissions. Newer versions --- of base have a new function with this behavior which we use on --- Windows when the new IO manager is used. openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) -openNewBinaryFile dir template = do - -- This method can't be used under WINIO. Also the current implementation has - -- thread safety issues depending on which GHC is used. On newer GHC's let's - -- use the built in one. -#if defined(__IO_MANAGER_WINIO__) - openBinaryTempFileWithDefaultPermissions dir template -#else - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below file path in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL .|. o_BINARY - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- TODO: We want to tell fdToHandle what the file path is, - -- as any exceptions etc will only be able to report the - -- FD currently - h <- fdToHandle fd `onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - - -- FIXME: bits copied from System.FilePath - combine a b - | null b = a - | null a = b - | last a == pathSeparator = a ++ b - | otherwise = a ++ [pathSeparator] ++ b - --- FIXME: Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR - --- FIXME: Should use System.FilePath library -pathSeparator :: Char -#ifdef mingw32_HOST_OS -pathSeparator = '\\' -#else -pathSeparator = '/' -#endif --- /* __IO_MANAGER_WINIO__ */ -#endif +openNewBinaryFile = openBinaryTempFileWithDefaultPermissions createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do @@ -122,12 +31,14 @@ findTempName pid where findTempName x = do - let dirpath = dir template ++ "-" ++ show x + let relpath = template ++ "-" ++ show x + dirpath = dir relpath r <- tryIO $ mkPrivateDir dirpath case r of - Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) - | otherwise -> ioError e + Right _ -> return relpath + Left e + | isAlreadyExistsError e -> findTempName (x + 1) + | otherwise -> ioError e mkPrivateDir :: String -> IO () #if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS) diff --git a/src/Distribution/Compat/Lens.hs b/src/Distribution/Compat/Lens.hs deleted file mode 100644 --- a/src/Distribution/Compat/Lens.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | This module provides very basic lens functionality, without extra dependencies. --- --- For the documentation of the combinators see package. --- This module uses the same vocabulary. -module Distribution.Compat.Lens ( - -- * Types - Lens, - Lens', - Traversal, - Traversal', - -- ** LensLike - LensLike, - LensLike', - -- ** rank-1 types - Getting, - AGetter, - ASetter, - ALens, - ALens', - -- * Getter - view, - use, - getting, - -- * Setter - set, - over, - -- * Fold - toDListOf, - toListOf, - toSetOf, - -- * Lens - cloneLens, - aview, - -- * Common lenses - _1, _2, - -- * Operators - (&), - (^.), - (.~), (?~), (%~), - (.=), (?=), (%=), - (^#), - (#~), (#%~), - -- * Internal Comonads - Pretext (..), - -- * Cabal developer info - -- $development - ) where - -import Prelude() -import Distribution.Compat.Prelude - -import Control.Monad.State.Class (MonadState (..), gets, modify) - -import qualified Distribution.Compat.DList as DList -import qualified Data.Set as Set - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type LensLike f s t a b = (a -> f b) -> s -> f t -type LensLike' f s a = (a -> f a) -> s -> f s - -type Lens s t a b = forall f. Functor f => LensLike f s t a b -type Traversal s t a b = forall f. Applicative f => LensLike f s t a b - -type Lens' s a = Lens s s a a -type Traversal' s a = Traversal s s a a - -type Getting r s a = LensLike (Const r) s s a a - -type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens' -type ASetter s t a b = LensLike Identity s t a b -type ALens s t a b = LensLike (Pretext a b) s t a b - -type ALens' s a = ALens s s a a - -------------------------------------------------------------------------------- --- Getter -------------------------------------------------------------------------------- - -view :: Getting a s a -> s -> a -view l s = getConst (l Const s) -{-# INLINE view #-} - -use :: MonadState s m => Getting a s a -> m a -use l = gets (view l) -{-# INLINE use #-} - --- | @since 2.4 --- --- >>> (3 :: Int) ^. getting (+2) . getting show --- "5" -getting :: (s -> a) -> Getting r s a -getting k f = Const . getConst . f . k -{-# INLINE getting #-} - -------------------------------------------------------------------------------- --- Setter -------------------------------------------------------------------------------- - -set :: ASetter s t a b -> b -> s -> t -set l x = over l (const x) - -over :: ASetter s t a b -> (a -> b) -> s -> t -over l f s = runIdentity (l (\x -> Identity (f x)) s) - -------------------------------------------------------------------------------- --- Fold -------------------------------------------------------------------------------- - -toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a -toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s) - -toListOf :: Getting (DList.DList a) s a -> s -> [a] -toListOf l = DList.runDList . toDListOf l - -toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a -toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s) - -------------------------------------------------------------------------------- --- Lens -------------------------------------------------------------------------------- - -aview :: ALens s t a b -> s -> a -aview l = pretextPos . l pretextSell -{-# INLINE aview #-} - -{- -lens :: (s -> a) -> (s -> a -> s) -> Lens' s a -lens sa sbt afb s = sbt s <$> afb (sa s) --} - -------------------------------------------------------------------------------- --- Common -------------------------------------------------------------------------------- - -_1 :: Lens (a, c) (b, c) a b -_1 f (a, c) = flip (,) c <$> f a - -_2 :: Lens (c, a) (c, b) a b -_2 f (c, a) = (,) c <$> f a - -------------------------------------------------------------------------------- --- Operators -------------------------------------------------------------------------------- - --- | '&' is a reverse application operator -(&) :: a -> (a -> b) -> b -(&) = flip ($) -{-# INLINE (&) #-} -infixl 1 & - -infixl 8 ^., ^# -infixr 4 .~, %~, ?~ -infixr 4 #~, #%~ -infixr 4 .=, %=, ?= - -(^.) :: s -> Getting a s a -> a -s ^. l = getConst (l Const s) -{-# INLINE (^.) #-} - -(.~) :: ASetter s t a b -> b -> s -> t -(.~) = set -{-# INLINE (.~) #-} - -(?~) :: ASetter s t a (Maybe b) -> b -> s -> t -l ?~ b = set l (Just b) -{-# INLINE (?~) #-} - -(%~) :: ASetter s t a b -> (a -> b) -> s -> t -(%~) = over -{-# INLINE (%~) #-} - -(.=) :: MonadState s m => ASetter s s a b -> b -> m () -l .= b = modify (l .~ b) -{-# INLINE (.=) #-} - -(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m () -l ?= b = modify (l ?~ b) -{-# INLINE (?=) #-} - -(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m () -l %= f = modify (l %~ f) -{-# INLINE (%=) #-} - -(^#) :: s -> ALens s t a b -> a -s ^# l = aview l s - -(#~) :: ALens s t a b -> b -> s -> t -(#~) l b s = pretextPeek b (l pretextSell s) -{-# INLINE (#~) #-} - -(#%~) :: ALens s t a b -> (a -> b) -> s -> t -(#%~) l f s = pretextPeeks f (l pretextSell s) -{-# INLINE (#%~) #-} - -pretextSell :: a -> Pretext a b b -pretextSell a = Pretext (\afb -> afb a) -{-# INLINE pretextSell #-} - -pretextPeeks :: (a -> b) -> Pretext a b t -> t -pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x)) -{-# INLINE pretextPeeks #-} - -pretextPeek :: b -> Pretext a b t -> t -pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b) -{-# INLINE pretextPeek #-} - -pretextPos :: Pretext a b t -> a -pretextPos (Pretext m) = getConst (m Const) -{-# INLINE pretextPos #-} - -cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b -cloneLens l f s = runPretext (l pretextSell s) f -{-# INLINE cloneLens #-} - -------------------------------------------------------------------------------- --- Comonads -------------------------------------------------------------------------------- - --- | @lens@ variant is also parametrised by profunctor. -data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t } - -instance Functor (Pretext a b) where - fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb)) - -------------------------------------------------------------------------------- --- Documentation -------------------------------------------------------------------------------- - --- $development --- --- We cannot depend on @template-haskell@, because Cabal is a boot library. --- This fact makes defining optics a manual task. Here is a small recipe to --- make the process less tedious. --- --- First start a repl --- --- > cabal new-repl Cabal:hackage-tests --- --- Because @--extra-package@ isn't yet implemented, we use a test-suite --- with @generics-sop@ dependency. --- --- In the repl, we load a helper script: --- --- > :l ../generics-sop-lens.hs --- --- Now we are set up to derive lenses! --- --- > :m +Distribution.Types.SourceRepo --- > putStr $ genericLenses (Proxy :: Proxy SourceRepo) --- --- @ --- repoKind :: Lens' SourceRepo RepoKind --- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s)) --- \{-# INLINE repoKind #-\} --- ... --- @ --- --- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`. diff --git a/src/Distribution/Compat/MonadFail.hs b/src/Distribution/Compat/MonadFail.hs deleted file mode 100644 --- a/src/Distribution/Compat/MonadFail.hs +++ /dev/null @@ -1,5 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Compatibility layer for "Control.Monad.Fail" -module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where -import Control.Monad.Fail diff --git a/src/Distribution/Compat/Newtype.hs b/src/Distribution/Compat/Newtype.hs deleted file mode 100644 --- a/src/Distribution/Compat/Newtype.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} --- | Per Conor McBride, the 'Newtype' typeclass represents the packing and --- unpacking of a newtype, and allows you to operatate under that newtype with --- functions such as 'ala'. -module Distribution.Compat.Newtype ( - Newtype (..), - ala, - alaf, - pack', - unpack', - ) where - -import Data.Functor.Identity (Identity (..)) -import Data.Monoid (Sum (..), Product (..), Endo (..)) - -#if MIN_VERSION_base(4,7,0) -import Data.Coerce (coerce, Coercible) -#else -import Unsafe.Coerce (unsafeCoerce) -#endif - --- | The @FunctionalDependencies@ version of 'Newtype' type-class. --- --- Since Cabal-3.0 class arguments are in a different order than in @newtype@ package. --- This change is to allow usage with @DeriveAnyClass@ (and @DerivingStrategies@, in GHC-8.2). --- Unfortunately one has to repeat inner type. --- --- @ --- newtype New = New Old --- deriving anyclass (Newtype Old) --- @ --- --- Another approach would be to use @TypeFamilies@ (and possibly --- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@ --- version gives cleaner type signatures. --- -class Newtype o n | n -> o where - pack :: o -> n -#if MIN_VERSION_base(4,7,0) - default pack :: Coercible o n => o -> n - pack = coerce -#else - default pack :: o -> n - pack = unsafeCoerce -#endif - - unpack :: n -> o -#if MIN_VERSION_base(4,7,0) - default unpack :: Coercible n o => n -> o - unpack = coerce -#else - default unpack :: n -> o - unpack = unsafeCoerce -#endif - -instance Newtype a (Identity a) -instance Newtype a (Sum a) -instance Newtype a (Product a) -instance Newtype (a -> a) (Endo a) - --- | --- --- >>> ala Sum foldMap [1, 2, 3, 4 :: Int] --- 10 --- --- /Note:/ the user supplied function for the newtype is /ignored/. --- --- >>> ala (Sum . (+1)) foldMap [1, 2, 3, 4 :: Int] --- 10 -ala :: (Newtype o n, Newtype o' n') => (o -> n) -> ((o -> n) -> b -> n') -> (b -> o') -ala pa hof = alaf pa hof id - --- | --- --- >>> alaf Sum foldMap length ["cabal", "install"] --- 12 --- --- /Note:/ as with 'ala', the user supplied function for the newtype is /ignored/. -alaf :: (Newtype o n, Newtype o' n') => (o -> n) -> ((a -> n) -> b -> n') -> (a -> o) -> (b -> o') -alaf _ hof f = unpack . hof (pack . f) - --- | Variant of 'pack', which takes a phantom type. -pack' :: Newtype o n => (o -> n) -> o -> n -pack' _ = pack - --- | Variant of 'unpack', which takes a phantom type. -unpack' :: Newtype o n => (o -> n) -> n -> o -unpack' _ = unpack diff --git a/src/Distribution/Compat/NonEmptySet.hs b/src/Distribution/Compat/NonEmptySet.hs deleted file mode 100644 --- a/src/Distribution/Compat/NonEmptySet.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -module Distribution.Compat.NonEmptySet ( - NonEmptySet, - -- * Construction - singleton, - -- * Insertion - insert, - -- * Deletion - delete, - -- * Conversions - toNonEmpty, - fromNonEmpty, - toList, - toSet, - -- * Query - member, - -- * Map - map, -) where - -import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.)) - -import Control.DeepSeq (NFData (..)) -import Data.Data (Data) -import Data.List.NonEmpty (NonEmpty (..)) -import Data.Semigroup (Semigroup (..)) -import Data.Typeable (Typeable) - -import qualified Data.Foldable as F -import qualified Data.Set as Set - -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Utils.Structured - -#if MIN_VERSION_binary(0,6,0) -import Control.Applicative (empty) -#else -import Control.Monad (fail) -#endif - --- | @since 3.4.0.0 -newtype NonEmptySet a = NES (Set.Set a) - deriving (Eq, Ord, Typeable, Data, Read) - -------------------------------------------------------------------------------- --- Instances -------------------------------------------------------------------------------- - -instance Show a => Show (NonEmptySet a) where - showsPrec d s = showParen (d > 10) - $ showString "fromNonEmpty " - . showsPrec 11 (toNonEmpty s) - -instance Binary a => Binary (NonEmptySet a) where - put (NES s) = put s - get = do - xs <- get - if Set.null xs -#if MIN_VERSION_binary(0,6,0) - then empty -#else - then fail "NonEmptySet: empty" -#endif - else return (NES xs) - -instance Structured a => Structured (NonEmptySet a) where - structure = containerStructure - -instance NFData a => NFData (NonEmptySet a) where - rnf (NES x) = rnf x - --- | Note: there aren't @Monoid@ instance. -instance Ord a => Semigroup (NonEmptySet a) where - NES x <> NES y = NES (Set.union x y) - -instance F.Foldable NonEmptySet where - foldMap f (NES s) = F.foldMap f s - foldr f z (NES s) = F.foldr f z s - -#if MIN_VERSION_base(4,8,0) - toList = toList - null _ = False - length (NES s) = F.length s -#endif - -------------------------------------------------------------------------------- --- Constructors -------------------------------------------------------------------------------- - -singleton :: a -> NonEmptySet a -singleton = NES . Set.singleton - -------------------------------------------------------------------------------- --- Insertion -------------------------------------------------------------------------------- - -insert :: Ord a => a -> NonEmptySet a -> NonEmptySet a -insert x (NES xs) = NES (Set.insert x xs) - -------------------------------------------------------------------------------- --- Deletion -------------------------------------------------------------------------------- - -delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a) -delete x (NES xs) - | Set.null res = Nothing - | otherwise = Just (NES xs) - where - res = Set.delete x xs - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - -fromNonEmpty :: Ord a => NonEmpty a -> NonEmptySet a -fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs)) - -toNonEmpty :: NonEmptySet a -> NonEmpty a -toNonEmpty (NES s) = case Set.toList s of - [] -> panic "toNonEmpty" - x:xs -> x :| xs - -toList :: NonEmptySet a -> [a] -toList (NES s) = Set.toList s - -toSet :: NonEmptySet a -> Set.Set a -toSet (NES s) = s - -------------------------------------------------------------------------------- --- Query -------------------------------------------------------------------------------- - -member :: Ord a => a -> NonEmptySet a -> Bool -member x (NES xs) = Set.member x xs - -------------------------------------------------------------------------------- --- Map -------------------------------------------------------------------------------- - -map - :: ( Ord b -#if !MIN_VERSION_containers(0,5,2) - , Ord a -#endif - ) - => (a -> b) -> NonEmptySet a -> NonEmptySet b -map f (NES x) = NES (Set.map f x) - -------------------------------------------------------------------------------- --- Internal -------------------------------------------------------------------------------- - -panic :: String -> a -panic msg = error $ "NonEmptySet invariant violated: " ++ msg diff --git a/src/Distribution/Compat/Parsing.hs b/src/Distribution/Compat/Parsing.hs deleted file mode 100644 --- a/src/Distribution/Compat/Parsing.hs +++ /dev/null @@ -1,362 +0,0 @@ -{-# LANGUAGE GADTs, UndecidableInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compat.Parsing --- Copyright : (c) Edward Kmett 2011-2012 --- License : BSD3 --- --- Maintainer : ekmett@gmail.com --- Stability : experimental --- Portability : non-portable --- --- Alternative parser combinators. --- --- Originally in @parsers@ package. --- ------------------------------------------------------------------------------ -module Distribution.Compat.Parsing - ( - -- * Parsing Combinators - choice - , option - , optional -- from Control.Applicative, parsec optionMaybe - , skipOptional -- parsec optional - , between - , some -- from Control.Applicative, parsec many1 - , many -- from Control.Applicative - , sepBy - , sepByNonEmpty - , sepEndByNonEmpty - , sepEndBy - , endByNonEmpty - , endBy - , count - , chainl - , chainr - , chainl1 - , chainr1 - , manyTill - -- * Parsing Class - , Parsing(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Applicative ((<**>), optional) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State.Lazy as Lazy -import Control.Monad.Trans.State.Strict as Strict -import Control.Monad.Trans.Writer.Lazy as Lazy -import Control.Monad.Trans.Writer.Strict as Strict -import Control.Monad.Trans.RWS.Lazy as Lazy -import Control.Monad.Trans.RWS.Strict as Strict -import Control.Monad.Trans.Reader (ReaderT (..)) -import Control.Monad.Trans.Identity (IdentityT (..)) -import Data.Foldable (asum) - -import qualified Data.List.NonEmpty as NE -import qualified Text.Parsec as Parsec - --- | @choice ps@ tries to apply the parsers in the list @ps@ in order, --- until one of them succeeds. Returns the value of the succeeding --- parser. -choice :: Alternative m => [m a] -> m a -choice = asum -{-# INLINE choice #-} - --- | @option x p@ tries to apply parser @p@. If @p@ fails without --- consuming input, it returns the value @x@, otherwise the value --- returned by @p@. --- --- > priority = option 0 (digitToInt <$> digit) -option :: Alternative m => a -> m a -> m a -option x p = p <|> pure x -{-# INLINE option #-} - --- | @skipOptional p@ tries to apply parser @p@. It will parse @p@ or nothing. --- It only fails if @p@ fails after consuming input. It discards the result --- of @p@. (Plays the role of parsec's optional, which conflicts with Applicative's optional) -skipOptional :: Alternative m => m a -> m () -skipOptional p = (() <$ p) <|> pure () -{-# INLINE skipOptional #-} - --- | @between open close p@ parses @open@, followed by @p@ and @close@. --- Returns the value returned by @p@. --- --- > braces = between (symbol "{") (symbol "}") -between :: Applicative m => m bra -> m ket -> m a -> m a -between bra ket p = bra *> p <* ket -{-# INLINE between #-} - --- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated --- by @sep@. Returns a list of values returned by @p@. --- --- > commaSep p = p `sepBy` (symbol ",") -sepBy :: Alternative m => m a -> m sep -> m [a] -sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] -{-# INLINE sepBy #-} - --- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- by @sep@. Returns a non-empty list of values returned by @p@. -sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) -{-# INLINE sepByNonEmpty #-} - --- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, --- separated and optionally ended by @sep@. Returns a non-empty list of values --- returned by @p@. -sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) - --- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, --- separated and optionally ended by @sep@, ie. haskell style --- statements. Returns a list of values returned by @p@. --- --- > haskellStatements = haskellStatement `sepEndBy` semi -sepEndBy :: Alternative m => m a -> m sep -> m [a] -sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] -{-# INLINE sepEndBy #-} - --- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a non-empty list of values returned by @p@. -endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) -endByNonEmpty p sep = NE.some1 (p <* sep) -{-# INLINE endByNonEmpty #-} - --- | @endBy p sep@ parses /zero/ or more occurrences of @p@, separated --- and ended by @sep@. Returns a list of values returned by @p@. --- --- > cStatements = cStatement `endBy` semi -endBy :: Alternative m => m a -> m sep -> m [a] -endBy p sep = many (p <* sep) -{-# INLINE endBy #-} - --- | @count n p@ parses @n@ occurrences of @p@. If @n@ is smaller or --- equal to zero, the parser equals to @return []@. Returns a list of --- @n@ values returned by @p@. -count :: Applicative m => Int -> m a -> m [a] -count n p | n <= 0 = pure [] - | otherwise = sequenceA (replicate n p) -{-# INLINE count #-} - --- | @chainr p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are no occurrences of @p@, the value @x@ is --- returned. -chainr :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainr p op x = chainr1 p op <|> pure x -{-# INLINE chainr #-} - --- | @chainl p op x@ parses /zero/ or more occurrences of @p@, --- separated by @op@. Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. If there are zero occurrences of @p@, the value @x@ is --- returned. -chainl :: Alternative m => m a -> m (a -> a -> a) -> a -> m a -chainl p op x = chainl1 p op <|> pure x -{-# INLINE chainl #-} - --- | @chainl1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /left/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. . This parser can for example be used to eliminate left --- recursion which typically occurs in expression grammars. --- --- > expr = term `chainl1` addop --- > term = factor `chainl1` mulop --- > factor = parens expr <|> integer --- > --- > mulop = (*) <$ symbol "*" --- > <|> div <$ symbol "/" --- > --- > addop = (+) <$ symbol "+" --- > <|> (-) <$ symbol "-" -chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainl1 p op = scan where - scan = p <**> rst - rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id -{-# INLINE chainl1 #-} - --- | @chainr1 p op x@ parses /one/ or more occurrences of @p@, --- separated by @op@ Returns a value obtained by a /right/ associative --- application of all functions returned by @op@ to the values returned --- by @p@. -chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a -chainr1 p op = scan where - scan = p <**> rst - rst = (flip <$> op <*> scan) <|> pure id -{-# INLINE chainr1 #-} - --- | @manyTill p end@ applies parser @p@ /zero/ or more times until --- parser @end@ succeeds. Returns the list of values returned by @p@. --- This parser can be used to scan comments: --- --- > simpleComment = do{ string "")) --- > } --- --- Note the overlapping parsers @anyChar@ and @string \"-->\"@, and --- therefore the use of the 'try' combinator. -manyTill :: Alternative m => m a -> m end -> m [a] -manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go) -{-# INLINE manyTill #-} - -infixr 0 - --- | Additional functionality needed to describe parsers independent of input type. -class Alternative m => Parsing m where - -- | Take a parser that may consume input, and on failure, go back to - -- where we started and fail as if we didn't consume input. - try :: m a -> m a - - -- | Give a parser a name - () :: m a -> String -> m a - - -- | A version of many that discards its input. Specialized because it - -- can often be implemented more cheaply. - skipMany :: m a -> m () - skipMany p = () <$ many p - {-# INLINE skipMany #-} - - -- | @skipSome p@ applies the parser @p@ /one/ or more times, skipping - -- its result. (aka skipMany1 in parsec) - skipSome :: m a -> m () - skipSome p = p *> skipMany p - {-# INLINE skipSome #-} - - -- | Used to emit an error on an unexpected token - unexpected :: String -> m a - - -- | This parser only succeeds at the end of the input. This is not a - -- primitive parser but it is defined using 'notFollowedBy'. - -- - -- > eof = notFollowedBy anyChar "end of input" - eof :: m () - - -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser - -- does not consume any input. This parser can be used to implement the - -- \'longest match\' rule. For example, when recognizing keywords (for - -- example @let@), we want to make sure that a keyword is not followed - -- by a legal identifier character, in which case the keyword is - -- actually an identifier (for example @lets@). We can program this - -- behaviour as follows: - -- - -- > keywordLet = try $ string "let" <* notFollowedBy alphaNum - notFollowedBy :: Show a => m a -> m () - -instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where - try (Lazy.StateT m) = Lazy.StateT $ try . m - {-# INLINE try #-} - Lazy.StateT m l = Lazy.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.StateT m) = Lazy.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where - try (Strict.StateT m) = Strict.StateT $ try . m - {-# INLINE try #-} - Strict.StateT m l = Strict.StateT $ \s -> m s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.StateT m) = Strict.StateT - $ \s -> notFollowedBy (fst <$> m s) >> return ((),s) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where - try (ReaderT m) = ReaderT $ try . m - {-# INLINE try #-} - ReaderT m l = ReaderT $ \e -> m e l - {-# INLINE () #-} - skipMany (ReaderT m) = ReaderT $ skipMany . m - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (ReaderT m) = ReaderT $ notFollowedBy . m - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) where - try (Strict.WriterT m) = Strict.WriterT $ try m - {-# INLINE try #-} - Strict.WriterT m l = Strict.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.WriterT m) = Strict.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where - try (Lazy.WriterT m) = Lazy.WriterT $ try m - {-# INLINE try #-} - Lazy.WriterT m l = Lazy.WriterT (m l) - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.WriterT m) = Lazy.WriterT - $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where - try (Lazy.RWST m) = Lazy.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Lazy.RWST m l = Lazy.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Lazy.RWST m) = Lazy.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where - try (Strict.RWST m) = Strict.RWST $ \r s -> try (m r s) - {-# INLINE try #-} - Strict.RWST m l = Strict.RWST $ \r s -> m r s l - {-# INLINE () #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (Strict.RWST m) = Strict.RWST - $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty) - {-# INLINE notFollowedBy #-} - -instance (Parsing m, Monad m) => Parsing (IdentityT m) where - try = IdentityT . try . runIdentityT - {-# INLINE try #-} - IdentityT m l = IdentityT (m l) - {-# INLINE () #-} - skipMany = IdentityT . skipMany . runIdentityT - {-# INLINE skipMany #-} - unexpected = lift . unexpected - {-# INLINE unexpected #-} - eof = lift eof - {-# INLINE eof #-} - notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - {-# INLINE notFollowedBy #-} - -instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where - try = Parsec.try - () = (Parsec.) - skipMany = Parsec.skipMany - skipSome = Parsec.skipMany1 - unexpected = Parsec.unexpected - eof = Parsec.eof - notFollowedBy = Parsec.notFollowedBy diff --git a/src/Distribution/Compat/Prelude.hs b/src/Distribution/Compat/Prelude.hs deleted file mode 100644 --- a/src/Distribution/Compat/Prelude.hs +++ /dev/null @@ -1,316 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} - -#ifdef MIN_VERSION_base -#define MINVER_base_411 MIN_VERSION_base(4,11,0) -#define MINVER_base_48 MIN_VERSION_base(4,8,0) -#define MINVER_base_47 MIN_VERSION_base(4,7,0) -#else -#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804) -#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710) -#define MINVER_base_47 (__GLASGOW_HASKELL__ >= 708) -#endif - --- | This module does two things: --- --- * Acts as a compatibility layer, like @base-compat@. --- --- * Provides commonly used imports. -module Distribution.Compat.Prelude ( - -- * Prelude - -- - -- Prelude is re-exported, following is hidden: - module BasePrelude, - -#if !MINVER_base_48 - -- * base 4.8 shim - Applicative(..), (<$), (<$>), - Monoid(..), -#endif - - -- * Common type-classes - Semigroup (..), - gmappend, gmempty, - Typeable, TypeRep, typeRep, - Data, - Generic, - NFData (..), genericRnf, - Binary (..), - Structured, - Alternative (..), - MonadPlus (..), - IsString (..), - - -- * Some types - Map, - Set, - NonEmptySet, - Identity (..), - Proxy (..), - Const (..), - Void, - - -- * Data.Either - partitionEithers, - - -- * Data.Maybe - catMaybes, mapMaybe, - fromMaybe, - maybeToList, listToMaybe, - isNothing, isJust, - - -- * Data.List - unfoldr, - isPrefixOf, isSuffixOf, - intercalate, intersperse, - sort, sortBy, - nub, nubBy, - partition, - - -- * Data.List.NonEmpty - NonEmpty((:|)), nonEmpty, foldl1, foldr1, - head, tail, last, init, - - -- * Data.Foldable - Foldable, foldMap, foldr, - null, length, - find, foldl', - traverse_, for_, - any, all, - toList, - - -- * Data.Traversable - Traversable, traverse, sequenceA, - for, - - -- * Data.Function - on, - - -- * Data.Ord - comparing, - - -- * Control.Arrow - first, - - -- * Control.Monad - liftM, liftM2, - unless, when, - ap, void, - foldM, filterM, - join, guard, - - -- * Control.Exception - catch, throwIO, evaluate, - Exception (..), IOException, SomeException (..), -#if !MINVER_base_48 - displayException, -#endif - tryIO, catchIO, catchExit, - - -- * Control.DeepSeq - deepseq, force, - - -- * Data.Char - isSpace, isDigit, isUpper, isAlpha, isAlphaNum, - chr, ord, - toLower, toUpper, - - -- * Data.Void - absurd, vacuous, - - -- * Data.Word & Data.Int - Word, - Word8, Word16, Word32, Word64, - Int8, Int16, Int32, Int64, - - -- * Text.PrettyPrint - (<<>>), (Disp.<+>), - - -- * System.Exit - ExitCode (..), - exitWith, exitSuccess, exitFailure, - - -- * Text.Read - readMaybe, - - -- * Debug.Trace (as deprecated functions) - trace, traceShow, traceShowId, - ) where - --- We also could hide few partial function -import Prelude as BasePrelude hiding - ( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init - -- partial functions - , read - , foldr1, foldl1 -#if MINVER_base_411 - -- As of base 4.11.0.0 Prelude exports part of Semigroup(..). - -- Hide this so we instead rely on Distribution.Compat.Semigroup. - , Semigroup(..) -#endif -#if MINVER_base_48 - , Word - -- We hide them, as we import only some members - , Traversable, traverse, sequenceA - , Foldable, foldMap -#endif - ) - --- AMP -#if !MINVER_base_48 -import Control.Applicative (Applicative (..), (<$), (<$>)) -import Data.Foldable (toList) -import Distribution.Compat.Semigroup (Monoid (..)) -#else -import Data.Foldable (Foldable (toList), length, null) -#endif - -import Data.Foldable (Foldable (foldMap, foldr), all, any, find, foldl', for_, traverse_) -import Data.Traversable (Traversable (sequenceA, traverse), for) - -import qualified Data.Foldable - --- Extra exports -import Control.Applicative (Alternative (..)) -import Control.Applicative (Const (..)) -import Control.Arrow (first) -import Control.DeepSeq (NFData (..), deepseq, force) -import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO) -import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when) -import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper) -import Data.Data (Data) -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Functor.Identity (Identity (..)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr) -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty, head, init, last, tail) -import Data.Map (Map) -import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList) -import Data.Ord (comparing) -import Data.Proxy (Proxy (..)) -import Data.Set (Set) -import Data.String (IsString (..)) -import Data.Void (Void, absurd, vacuous) -import Data.Word (Word, Word16, Word32, Word64, Word8) -import Distribution.Compat.Binary (Binary (..)) -import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty) -import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep) -import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1) -import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith) -import Text.Read (readMaybe) - -import qualified Text.PrettyPrint as Disp - -import Distribution.Compat.Exception -import Distribution.Compat.NonEmptySet (NonEmptySet) -import Distribution.Utils.Structured (Structured) - -import qualified Debug.Trace - --- | New name for 'Text.PrettyPrint.<>' -(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc -(<<>>) = (Disp.<>) - -#if !MINVER_base_48 --- | Test whether the structure is empty. The default implementation is --- optimized for structures that are similar to cons-lists, because there --- is no general way to do better. -null :: Foldable t => t a -> Bool -null = foldr (\_ _ -> False) True - --- | Returns the size/length of a finite structure as an 'Int'. The --- default implementation is optimized for structures that are similar to --- cons-lists, because there is no general way to do better. -length :: Foldable t => t a -> Int -length = foldl' (\c _ -> c+1) 0 -#endif - - --- | "GHC.Generics"-based 'rnf' implementation --- --- This is needed in order to support @deepseq < 1.4@ which didn't --- have a 'Generic'-based default 'rnf' implementation yet. --- --- In order to define instances, use e.g. --- --- > instance NFData MyType where rnf = genericRnf --- --- The implementation has been taken from @deepseq-1.4.2@'s default --- 'rnf' implementation. -genericRnf :: (Generic a, GNFData (Rep a)) => a -> () -genericRnf = grnf . from - --- | Hidden internal type-class -class GNFData f where - grnf :: f a -> () - -instance GNFData V1 where - grnf = error "Control.DeepSeq.rnf: uninhabited type" - -instance GNFData U1 where - grnf U1 = () - -instance NFData a => GNFData (K1 i a) where - grnf = rnf . unK1 - {-# INLINEABLE grnf #-} - -instance GNFData a => GNFData (M1 i c a) where - grnf = grnf . unM1 - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :*: b) where - grnf (x :*: y) = grnf x `seq` grnf y - {-# INLINEABLE grnf #-} - -instance (GNFData a, GNFData b) => GNFData (a :+: b) where - grnf (L1 x) = grnf x - grnf (R1 x) = grnf x - {-# INLINEABLE grnf #-} - - --- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we --- can define a local typeclass 'Foldable1', e.g. --- --- @ --- class Foldable f => Foldable1 f --- --- instance Foldable1 NonEmpty --- --- foldr1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldr1 = Data.Foldable.foldr1 --- --- foldl1 :: Foldable1 t => (a -> a -> a) -> t a -> a --- foldl1 = Data.Foldable.foldl1 --- @ --- - -{-# INLINE foldr1 #-} -foldr1 :: (a -> a -> a) -> NonEmpty a -> a -foldr1 = Data.Foldable.foldr1 - -{-# INLINE foldl1 #-} -foldl1 :: (a -> a -> a) -> NonEmpty a -> a -foldl1 = Data.Foldable.foldl1 - -------------------------------------------------------------------------------- --- Trace -------------------------------------------------------------------------------- - --- Functions from Debug.Trace --- but with DEPRECATED pragma, so -Werror will scream on them. - -trace :: String -> a -> a -trace = Debug.Trace.trace -{-# DEPRECATED trace "Don't leave me in the code" #-} - -traceShowId :: Show a => a -> a -traceShowId x = Debug.Trace.traceShow x x -{-# DEPRECATED traceShowId "Don't leave me in the code" #-} - -traceShow :: Show a => a -> b -> b -traceShow = Debug.Trace.traceShow -{-# DEPRECATED traceShow "Don't leave me in the code" #-} diff --git a/src/Distribution/Compat/Prelude/Internal.hs b/src/Distribution/Compat/Prelude/Internal.hs --- a/src/Distribution/Compat/Prelude/Internal.hs +++ b/src/Distribution/Compat/Prelude/Internal.hs @@ -7,8 +7,8 @@ -- for @Setup.hs@ scripts since its API is /not/ -- stable. module Distribution.Compat.Prelude.Internal - {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} - ( module Distribution.Compat.Prelude - ) where + {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-} + ( module Distribution.Compat.Prelude + ) where import Distribution.Compat.Prelude diff --git a/src/Distribution/Compat/Process.hs b/src/Distribution/Compat/Process.hs --- a/src/Distribution/Compat/Process.hs +++ b/src/Distribution/Compat/Process.hs @@ -1,22 +1,15 @@ {-# LANGUAGE CPP #-} -module Distribution.Compat.Process ( - -- * Redefined functions - createProcess, - runInteractiveProcess, - rawSystem, - -- * Additions - enableProcessJobs, - ) where -import System.Exit (ExitCode (..)) -import System.IO (Handle) +module Distribution.Compat.Process + ( -- * Redefined functions + proc -import System.Process (CreateProcess, ProcessHandle) -import qualified System.Process as Process + -- * Additions + , enableProcessJobs + ) where -#if MIN_VERSION_process(1,2,0) -import System.Process (waitForProcess) -#endif +import System.Process (CreateProcess) +import qualified System.Process as Process #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9) import System.IO.Unsafe (unsafePerformIO) @@ -48,7 +41,7 @@ -- On Windows 7 or before the jobs are disabled due to the fact that -- processes on these systems can only have one job. This prevents -- spawned process from assigning jobs to its own children. Suppose --- processs A spawns process B. The B process has a job assigned (call +-- process A spawns process B. The B process has a job assigned (call -- it J1) and when it tries to spawn a new process C the C -- automatically inherits the job. But at it also tries to assign a -- new job J2 to C since it doesn’t have access J1. This fails on @@ -64,40 +57,7 @@ -- process redefinitions ------------------------------------------------------------------------------- --- | 'System.Process.createProcess' with process jobs enabled when appropriate. --- See 'enableProcessJobs'. -createProcess :: CreateProcess - -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess = Process.createProcess . enableProcessJobs - --- | 'System.Process.rawSystem' with process jobs enabled when appropriate. --- See 'enableProcessJobs'. -rawSystem :: String -> [String] -> IO ExitCode -rawSystem cmd args = do -#if MIN_VERSION_process(1,2,0) - (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } - waitForProcess p -#else - -- With very old 'process', just do its rawSystem - Process.rawSystem cmd args -#endif - --- | 'System.Process.runInteractiveProcess' with process jobs enabled when --- appropriate. See 'enableProcessJobs'. -runInteractiveProcess - :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) - -> [String] -- ^ Arguments to pass to the executable - -> Maybe FilePath -- ^ Optional path to the working directory - -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) - -> IO (Handle,Handle,Handle,ProcessHandle) -runInteractiveProcess cmd args mb_cwd mb_env = do - (mb_in, mb_out, mb_err, p) <- - createProcess (Process.proc cmd args) - { Process.std_in = Process.CreatePipe, - Process.std_out = Process.CreatePipe, - Process.std_err = Process.CreatePipe, - Process.env = mb_env, - Process.cwd = mb_cwd } - return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) - where - fromJust = maybe (error "runInteractiveProcess: fromJust") id +-- | 'System.Process.proc' with process jobs enabled when appropriate, +-- and defaulting 'delegate_ctlc' to 'True'. +proc :: FilePath -> [String] -> CreateProcess +proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True} diff --git a/src/Distribution/Compat/ResponseFile.hs b/src/Distribution/Compat/ResponseFile.hs --- a/src/Distribution/Compat/ResponseFile.hs +++ b/src/Distribution/Compat/ResponseFile.hs @@ -1,54 +1,27 @@ -{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} -- Compatibility layer for GHC.ResponseFile -- Implementation from base 4.12.0 is used. -- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE -module Distribution.Compat.ResponseFile (expandResponse) where +module Distribution.Compat.ResponseFile (expandResponse, escapeArgs) where import Distribution.Compat.Prelude + +import GHC.ResponseFile (escapeArgs, unescapeArgs) + import Prelude () import System.FilePath import System.IO (hPutStrLn, stderr) import System.IO.Error -#if MIN_VERSION_base(4,12,0) -import GHC.ResponseFile (unescapeArgs) -#else - -unescapeArgs :: String -> [String] -unescapeArgs = filter (not . null) . unescape - -data Quoting = NoneQ | SngQ | DblQ - -unescape :: String -> [String] -unescape args = reverse . map reverse $ go args NoneQ False [] [] - where - -- n.b., the order of these cases matters; these are cribbed from gcc - -- case 1: end of input - go [] _q _bs a as = a:as - -- case 2: back-slash escape in progress - go (c:cs) q True a as = go cs q False (c:a) as - -- case 3: no back-slash escape in progress, but got a back-slash - go (c:cs) q False a as - | '\\' == c = go cs q True a as - -- case 4: single-quote escaping in progress - go (c:cs) SngQ False a as - | '\'' == c = go cs NoneQ False a as - | otherwise = go cs SngQ False (c:a) as - -- case 5: double-quote escaping in progress - go (c:cs) DblQ False a as - | '"' == c = go cs NoneQ False a as - | otherwise = go cs DblQ False (c:a) as - -- case 6: no escaping is in progress - go (c:cs) NoneQ False a as - | isSpace c = go cs NoneQ False [] (a:as) - | '\'' == c = go cs SngQ False a as - | '"' == c = go cs DblQ False a as - | otherwise = go cs NoneQ False (c:a) as - -#endif - +-- | The arg file / response file parser. +-- +-- This is not a well-documented capability, and is a bit eccentric +-- (try @cabal \@foo \@bar@ to see what that does), but is crucial +-- for allowing complex arguments to cabal and cabal-install when +-- using command prompts with strongly-limited argument length. expandResponse :: [String] -> IO [String] expandResponse = go recursionLimit "." where @@ -56,11 +29,11 @@ go :: Int -> FilePath -> [String] -> IO [String] go n dir - | n >= 0 = fmap concat . traverse (expand n dir) + | n >= 0 = fmap concat . traverse (expand n dir) | otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure expand :: Int -> FilePath -> String -> IO [String] - expand n dir arg@('@':f) = readRecursively n (dir f) `catchIOError` (const $ print "?" >> return [arg]) + expand n dir arg@('@' : f) = readRecursively n (dir f) `catchIOError` const (print "?" >> return [arg]) expand _n _dir x = return [x] readRecursively :: Int -> FilePath -> IO [String] diff --git a/src/Distribution/Compat/Semigroup.hs b/src/Distribution/Compat/Semigroup.hs deleted file mode 100644 --- a/src/Distribution/Compat/Semigroup.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE TypeOperators #-} - --- | Compatibility layer for "Data.Semigroup" -module Distribution.Compat.Semigroup - ( Semigroup((<>)) - , Mon.Monoid(..) - , All(..) - , Any(..) - - , First'(..) - , Last'(..) - - , Option'(..) - - , gmappend - , gmempty - ) where - -import Distribution.Compat.Binary (Binary) -import Distribution.Utils.Structured (Structured) -import Data.Typeable (Typeable) - -import GHC.Generics --- Data.Semigroup is available since GHC 8.0/base-4.9 in `base` --- for older GHC/base, it's provided by `semigroups` -import Data.Semigroup -import qualified Data.Monoid as Mon - - --- | A copy of 'Data.Semigroup.First'. -newtype First' a = First' { getFirst' :: a } - deriving (Eq, Ord, Show) - -instance Semigroup (First' a) where - a <> _ = a - --- | A copy of 'Data.Semigroup.Last'. -newtype Last' a = Last' { getLast' :: a } - deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable) - -instance Structured a => Structured (Last' a) - -instance Semigroup (Last' a) where - _ <> b = b - -instance Functor Last' where - fmap f (Last' x) = Last' (f x) - --- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances --- implemented for 'Maybe' since @base-4.11@. -newtype Option' a = Option' { getOption' :: Maybe a } - deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable) - -instance Structured a => Structured (Option' a) - -instance Semigroup a => Semigroup (Option' a) where - Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b)) - Option' Nothing <> b = b - a <> Option' Nothing = a - -instance Semigroup a => Monoid (Option' a) where - mempty = Option' Nothing - mappend = (<>) - -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- --- Stolen from Edward Kmett's BSD3-licensed `semigroups` package - --- | Generically generate a 'Semigroup' ('<>') operation for any type --- implementing 'Generic'. This operation will append two values --- by point-wise appending their component fields. It is only defined --- for product types. --- --- @ --- 'gmappend' a ('gmappend' b c) = 'gmappend' ('gmappend' a b) c --- @ -gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a -gmappend x y = to (gmappend' (from x) (from y)) - -class GSemigroup f where - gmappend' :: f p -> f p -> f p - -instance Semigroup a => GSemigroup (K1 i a) where - gmappend' (K1 x) (K1 y) = K1 (x <> y) - -instance GSemigroup f => GSemigroup (M1 i c f) where - gmappend' (M1 x) (M1 y) = M1 (gmappend' x y) - -instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where - gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2 - --- | Generically generate a 'Monoid' 'mempty' for any product-like type --- implementing 'Generic'. --- --- It is only defined for product types. --- --- @ --- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty' --- @ - -gmempty :: (Generic a, GMonoid (Rep a)) => a -gmempty = to gmempty' - -class GSemigroup f => GMonoid f where - gmempty' :: f p - -instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where - gmempty' = K1 mempty - -instance GMonoid f => GMonoid (M1 i c f) where - gmempty' = M1 gmempty' - -instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where - gmempty' = gmempty' :*: gmempty' diff --git a/src/Distribution/Compat/SnocList.hs b/src/Distribution/Compat/SnocList.hs --- a/src/Distribution/Compat/SnocList.hs +++ b/src/Distribution/Compat/SnocList.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Compat.SnocList -- License : BSD3 @@ -8,14 +9,14 @@ -- Portability : portable -- -- A very reversed list. Has efficient `snoc` -module Distribution.Compat.SnocList ( - SnocList, - runSnocList, - snoc, -) where +module Distribution.Compat.SnocList + ( SnocList + , runSnocList + , snoc + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () newtype SnocList a = SnocList [a] @@ -26,8 +27,8 @@ runSnocList (SnocList xs) = reverse xs instance Semigroup (SnocList a) where - SnocList xs <> SnocList ys = SnocList (ys <> xs) + SnocList xs <> SnocList ys = SnocList (ys <> xs) instance Monoid (SnocList a) where - mempty = SnocList [] - mappend = (<>) + mempty = SnocList [] + mappend = (<>) diff --git a/src/Distribution/Compat/Stack.hs b/src/Distribution/Compat/Stack.hs --- a/src/Distribution/Compat/Stack.hs +++ b/src/Distribution/Compat/Stack.hs @@ -1,102 +1,42 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ImplicitParams #-} -module Distribution.Compat.Stack ( - WithCallStack, - CallStack, - annotateCallStackIO, - withFrozenCallStack, - withLexicalCallStack, - callStack, - prettyCallStack, - parentSrcLocPrefix -) where - -import System.IO.Error +{-# LANGUAGE RankNTypes #-} -#ifdef MIN_VERSION_base -#if MIN_VERSION_base(4,8,1) -#define GHC_STACK_SUPPORTED 1 -#endif -#endif +module Distribution.Compat.Stack + ( WithCallStack + , CallStack + , annotateCallStackIO + , withFrozenCallStack + , withLexicalCallStack + , callStack + , prettyCallStack + , parentSrcLocPrefix + ) where -#ifdef GHC_STACK_SUPPORTED import GHC.Stack -#endif - -#ifdef GHC_STACK_SUPPORTED +import System.IO.Error -#if MIN_VERSION_base(4,9,0) type WithCallStack a = HasCallStack => a -#elif MIN_VERSION_base(4,8,1) -type WithCallStack a = (?callStack :: CallStack) => a -#endif -#if !MIN_VERSION_base(4,9,0) --- NB: Can't say WithCallStack (WithCallStack a -> a); --- Haskell doesn't support this kind of implicit parameter! --- See https://mail.haskell.org/pipermail/ghc-devs/2016-January/011096.html --- Since this function doesn't do anything, it's OK to --- give it a less good type. -withFrozenCallStack :: WithCallStack (a -> a) -withFrozenCallStack x = x - -callStack :: (?callStack :: CallStack) => CallStack -callStack = ?callStack - -prettyCallStack :: CallStack -> String -prettyCallStack = showCallStack -#endif - -- | Give the *parent* of the person who invoked this; -- so it's most suitable for being called from a utility function. -- You probably want to call this using 'withFrozenCallStack'; otherwise -- it's not very useful. We didn't implement this for base-4.8.1 -- because we cannot rely on freezing to have taken place. --- parentSrcLocPrefix :: WithCallStack String -#if MIN_VERSION_base(4,9,0) parentSrcLocPrefix = case getCallStack callStack of - (_:(_, loc):_) -> showLoc loc + (_ : (_, loc) : _) -> showLoc loc [(_, loc)] -> showLoc loc [] -> error "parentSrcLocPrefix: empty call stack" - where - showLoc loc = - srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " -#else -parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " -#endif + where + showLoc loc = + srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ ": " -- Yeah, this uses skivvy implementation details. withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b) withLexicalCallStack f = - let stk = ?callStack - in \x -> let ?callStack = stk in f x - -#else - -data CallStack = CallStack - deriving (Eq, Show) - -type WithCallStack a = a - -withFrozenCallStack :: a -> a -withFrozenCallStack x = x - -callStack :: CallStack -callStack = CallStack - -prettyCallStack :: CallStack -> String -prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)" - -parentSrcLocPrefix :: String -parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): " - -withLexicalCallStack :: (a -> IO b) -> a -> IO b -withLexicalCallStack f = f - -#endif + let stk = ?callStack + in \x -> let ?callStack = stk in f x -- | This function is for when you *really* want to add a call -- stack to raised IO, but you don't have a @@ -106,8 +46,9 @@ annotateCallStackIO :: WithCallStack (IO a -> IO a) annotateCallStackIO = modifyIOError f where - f ioe = ioeSetErrorString ioe - . wrapCallStack - $ ioeGetErrorString ioe + f ioe = + ioeSetErrorString ioe + . wrapCallStack + $ ioeGetErrorString ioe wrapCallStack s = - prettyCallStack callStack ++ "\n" ++ s + prettyCallStack callStack ++ "\n" ++ s diff --git a/src/Distribution/Compat/Time.hs b/src/Distribution/Compat/Time.hs --- a/src/Distribution/Compat/Time.hs +++ b/src/Distribution/Compat/Time.hs @@ -1,42 +1,39 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Compat.Time - ( ModTime(..) -- Needed for testing - , getModTime, getFileAge, getCurTime - , posixSecondsToModTime - , calibrateMtimeChangeDelay ) - where + ( ModTime (..) -- Needed for testing + , getModTime + , getFileAge + , getCurTime + , posixSecondsToModTime + , calibrateMtimeChangeDelay + ) +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import System.Directory ( getModificationTime ) +import System.Directory (getModificationTime) -import Distribution.Simple.Utils ( withTempDirectory ) -import Distribution.Verbosity ( silent ) +import Distribution.Simple.Utils (withTempDirectoryCwd) +import Distribution.Utils.Path (getSymbolicPath, sameDirectory) +import Distribution.Verbosity (silent) import System.FilePath -import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime ) -import Data.Time ( diffUTCTime, getCurrentTime ) -import Data.Time.Clock.POSIX ( posixDayLength ) - +import Data.Time (diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength) #if defined mingw32_HOST_OS import qualified Prelude import Data.Bits ((.|.), unsafeShiftL) -#if MIN_VERSION_base(4,7,0) import Data.Bits (finiteBitSize) -#else -import Data.Bits (bitSize) -#endif import Foreign ( allocaBytes, peekByteOff ) import System.IO.Error ( mkIOError, doesNotExistErrorType ) @@ -44,20 +41,21 @@ #else -import System.Posix.Files ( FileStatus, getFileStatus ) - +import System.Posix.Files + ( FileStatus, getFileStatus #if MIN_VERSION_unix(2,6,0) -import System.Posix.Files ( modificationTimeHiRes ) + , modificationTimeHiRes #else -import System.Posix.Files ( modificationTime ) + , modificationTime #endif + ) #endif -- | An opaque type representing a file's modification time, represented -- internally as a 64-bit unsigned integer in the Windows UTC format. newtype ModTime = ModTime Word64 - deriving (Binary, Generic, Bounded, Eq, Ord, Typeable) + deriving (Binary, Generic, Bounded, Eq, Ord) instance Structured ModTime @@ -90,18 +88,13 @@ index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime dwHigh <- peekByteOff info index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime -#if MIN_VERSION_base(4,7,0) let qwTime = (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` finiteBitSize dwHigh) .|. (fromIntegral (dwLow :: DWORD)) -#else - let qwTime = - (fromIntegral (dwHigh :: DWORD) `unsafeShiftL` bitSize dwHigh) - .|. (fromIntegral (dwLow :: DWORD)) -#endif return $! ModTime (qwTime :: Word64) -#ifdef x86_64_HOST_ARCH +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall @@ -138,9 +131,10 @@ extractFileTime x = posixTimeToModTime (modificationTimeHiRes x) #endif +{- FOURMOLU_ENABLE -} windowsTick, secToUnixEpoch :: Word64 -windowsTick = 10000000 +windowsTick = 10000000 secToUnixEpoch = 11644473600 -- | Convert POSIX seconds to ModTime. @@ -150,8 +144,10 @@ -- | Convert 'POSIXTime' to 'ModTime'. posixTimeToModTime :: POSIXTime -> ModTime -posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision - + (secToUnixEpoch * windowsTick) +posixTimeToModTime p = + ModTime $ + ceiling (p * 1e7) -- 100 ns precision + + (secToUnixEpoch * windowsTick) -- | Return age of given file in days. getFileAge :: FilePath -> IO Double @@ -172,17 +168,17 @@ -- than 10 ms, but never larger than 1 second. calibrateMtimeChangeDelay :: IO (Int, Int) calibrateMtimeChangeDelay = - withTempDirectory silent "." "calibration-" $ \dir -> do - let fileName = dir "probe" - mtimes <- for [1..25] $ \(i::Int) -> time $ do + withTempDirectoryCwd silent Nothing sameDirectory "calibration-" $ \dir -> do + let fileName = getSymbolicPath dir "probe" + mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do writeFile fileName $ show i t0 <- getModTime fileName let spin j = do - writeFile fileName $ show (i,j) + writeFile fileName $ show (i, j) t1 <- getModTime fileName unless (t0 < t1) (spin $ j + 1) - spin (0::Int) - let mtimeChange = maximum mtimes + spin (0 :: Int) + let mtimeChange = maximum mtimes mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2 return (mtimeChange, mtimeChange') where diff --git a/src/Distribution/Compat/Typeable.hs b/src/Distribution/Compat/Typeable.hs deleted file mode 100644 --- a/src/Distribution/Compat/Typeable.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Compat.Typeable ( - Typeable, - TypeRep, - typeRep, - ) where - -#if MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable, TypeRep, typeRep) -#else -import Data.Typeable (Typeable, TypeRep, typeOf) -#endif - -#if !MIN_VERSION_base(4,7,0) -typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep -typeRep _ = typeOf (undefined :: a) -#endif diff --git a/src/Distribution/Compiler.hs b/src/Distribution/Compiler.hs deleted file mode 100644 --- a/src/Distribution/Compiler.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Compiler --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has an enumeration of the various compilers that Cabal knows about. It --- also specifies the default compiler. Sadly you'll often see code that does --- case analysis on this compiler flavour enumeration like: --- --- > case compilerFlavor comp of --- > GHC -> GHC.getInstalledPackages verbosity packageDb progdb --- --- Obviously it would be better to use the proper 'Compiler' abstraction --- because that would keep all the compiler-specific code together. --- Unfortunately we cannot make this change yet without breaking the --- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the --- moment we just have to live with this deficiency. If you're interested, see --- ticket #57. - -module Distribution.Compiler ( - -- * Compiler flavor - CompilerFlavor(..), - buildCompilerId, - buildCompilerFlavor, - defaultCompilerFlavor, - classifyCompilerFlavor, - knownCompilerFlavors, - - -- * Per compiler flavor - PerCompilerFlavor (..), - perCompilerFlavorToList, - - -- * Compiler id - CompilerId(..), - - -- * Compiler info - CompilerInfo(..), - unknownCompilerInfo, - AbiTag(..), abiTagString - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Language.Haskell.Extension - -import Distribution.Version (Version, mkVersion', nullVersion) - -import qualified System.Info (compilerName, compilerVersion) -import Distribution.Parsec (Parsec (..)) -import Distribution.Pretty (Pretty (..), prettyShow) -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data CompilerFlavor = - GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta - | HaskellSuite String -- string is the id of the actual compiler - | OtherCompiler String - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary CompilerFlavor -instance Structured CompilerFlavor -instance NFData CompilerFlavor where rnf = genericRnf - -knownCompilerFlavors :: [CompilerFlavor] -knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC, Eta] - -instance Pretty CompilerFlavor where - pretty (OtherCompiler name) = Disp.text name - pretty (HaskellSuite name) = Disp.text name - pretty NHC = Disp.text "nhc98" - pretty other = Disp.text (lowercase (show other)) - -instance Parsec CompilerFlavor where - parsec = classifyCompilerFlavor <$> component - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digits compiler name" else return cs - -classifyCompilerFlavor :: String -> CompilerFlavor -classifyCompilerFlavor s = - fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap - where - compilerMap = [ (lowercase (prettyShow compiler), compiler) - | compiler <- knownCompilerFlavors ] - -buildCompilerFlavor :: CompilerFlavor -buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName - -buildCompilerVersion :: Version -buildCompilerVersion = mkVersion' System.Info.compilerVersion - -buildCompilerId :: CompilerId -buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion - --- | The default compiler flavour to pick when compiling stuff. This defaults --- to the compiler used to build the Cabal lib. --- --- However if it's not a recognised compiler then it's 'Nothing' and the user --- will have to specify which compiler they want. --- -defaultCompilerFlavor :: Maybe CompilerFlavor -defaultCompilerFlavor = case buildCompilerFlavor of - OtherCompiler _ -> Nothing - _ -> Just buildCompilerFlavor - -------------------------------------------------------------------------------- --- Per compiler data -------------------------------------------------------------------------------- - --- | 'PerCompilerFlavor' carries only info per GHC and GHCJS --- --- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted. --- -data PerCompilerFlavor v = PerCompilerFlavor v v - deriving (Generic, Show, Read, Eq, Typeable, Data, Functor, Foldable - , Traversable) - -instance Binary a => Binary (PerCompilerFlavor a) -instance Structured a => Structured (PerCompilerFlavor a) -instance NFData a => NFData (PerCompilerFlavor a) - -perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)] -perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)] - -instance Semigroup a => Semigroup (PerCompilerFlavor a) where - PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor - (a <> a') (b <> b') - -instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where - mempty = PerCompilerFlavor mempty mempty - mappend = (<>) - --- ------------------------------------------------------------ --- * Compiler Id --- ------------------------------------------------------------ - -data CompilerId = CompilerId CompilerFlavor Version - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary CompilerId -instance Structured CompilerId -instance NFData CompilerId where rnf = genericRnf - -instance Pretty CompilerId where - pretty (CompilerId f v) - | v == nullVersion = pretty f - | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v - -instance Parsec CompilerId where - parsec = do - flavour <- parsec - version <- (P.char '-' >> parsec) <|> return nullVersion - return (CompilerId flavour version) - -lowercase :: String -> String -lowercase = map toLower - --- ------------------------------------------------------------ --- * Compiler Info --- ------------------------------------------------------------ - --- | Compiler information used for resolving configurations. Some --- fields can be set to Nothing to indicate that the information is --- unknown. - -data CompilerInfo = CompilerInfo { - compilerInfoId :: CompilerId, - -- ^ Compiler flavour and version. - compilerInfoAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerInfoCompat :: Maybe [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with, if known. - compilerInfoLanguages :: Maybe [Language], - -- ^ Supported language standards, if known. - compilerInfoExtensions :: Maybe [Extension] - -- ^ Supported extensions, if known. - } - deriving (Generic, Show, Read) - -instance Binary CompilerInfo - -data AbiTag - = NoAbiTag - | AbiTag String - deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary AbiTag -instance Structured AbiTag - -instance Pretty AbiTag where - pretty NoAbiTag = Disp.empty - pretty (AbiTag tag) = Disp.text tag - -instance Parsec AbiTag where - parsec = do - tag <- P.munch (\c -> isAlphaNum c || c == '_') - if null tag then return NoAbiTag else return (AbiTag tag) - -abiTagString :: AbiTag -> String -abiTagString NoAbiTag = "" -abiTagString (AbiTag tag) = tag - --- | Make a CompilerInfo of which only the known information is its CompilerId, --- its AbiTag and that it does not claim to be compatible with other --- compiler id's. -unknownCompilerInfo :: CompilerId -> AbiTag -> CompilerInfo -unknownCompilerInfo compilerId abiTag = - CompilerInfo compilerId abiTag (Just []) Nothing Nothing diff --git a/src/Distribution/FieldGrammar.hs b/src/Distribution/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a way to specify a grammar of @.cabal@ -like files. -module Distribution.FieldGrammar ( - -- * Field grammar type - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - -- * Concrete grammar implementations - ParsecFieldGrammar, - ParsecFieldGrammar', - parseFieldGrammar, - fieldGrammarKnownFieldList, - PrettyFieldGrammar, - PrettyFieldGrammar', - prettyFieldGrammar, - -- * Auxlilary - (^^^), - Section(..), - Fields, - partitionFields, - takeFields, - runFieldParser, - runFieldParser', - defaultFreeTextFieldDefST, - -- * Newtypes - module Distribution.FieldGrammar.Newtypes, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import qualified Data.Map.Strict as Map - -import Distribution.FieldGrammar.Class -import Distribution.FieldGrammar.Newtypes -import Distribution.FieldGrammar.Parsec -import Distribution.FieldGrammar.Pretty -import Distribution.Fields.Field -import Distribution.Utils.Generic (spanMaybe) - -type ParsecFieldGrammar' a = ParsecFieldGrammar a a -type PrettyFieldGrammar' a = PrettyFieldGrammar a a - -infixl 5 ^^^ - --- | Reverse function application which binds tighter than '<$>' and '<*>'. --- Useful for refining grammar specification. --- --- @ --- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions --- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields." --- @ -(^^^) :: a -> (a -> b) -> b -x ^^^ f = f x - --- | Partitioning state -data PS ann = PS (Fields ann) [Section ann] [[Section ann]] - --- | Partition field list into field map and groups of sections. -partitionFields :: [Field ann] -> (Fields ann, [[Section ann]]) -partitionFields = finalize . foldl' f (PS mempty mempty mempty) - where - finalize :: PS ann -> (Fields ann, [[Section ann]]) - finalize (PS fs s ss) - | null s = (fs, reverse ss) - | otherwise = (fs, reverse (reverse s : ss)) - - f :: PS ann -> Field ann -> PS ann - f (PS fs s ss) (Field (Name ann name) fss) = - PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss' - where - ss' | null s = ss - | otherwise = reverse s : ss - f (PS fs s ss) (Section name sargs sfields) = - PS fs (MkSection name sargs sfields : s) ss - --- | Take all fields from the front. -takeFields :: [Field ann] -> (Fields ann, [Field ann]) -takeFields = finalize . spanMaybe match - where - finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest) - - match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs]) - match _ = Nothing diff --git a/src/Distribution/FieldGrammar/Class.hs b/src/Distribution/FieldGrammar/Class.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Class.hs +++ /dev/null @@ -1,205 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE UndecidableSuperClasses #-} -#else -{-# LANGUAGE UndecidableInstances #-} -#endif -module Distribution.FieldGrammar.Class ( - FieldGrammar (..), - uniqueField, - optionalField, - optionalFieldDef, - monoidalField, - defaultFreeTextFieldDefST, -) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compat.Newtype (Newtype) -import Distribution.FieldGrammar.Newtypes -import Distribution.Fields.Field -import Distribution.Utils.ShortText - --- | 'FieldGrammar' is parametrised by --- --- * @s@ which is a structure we are parsing. We need this to provide prettyprinter --- functionality --- --- * @a@ type of the field. --- --- /Note:/ We'd like to have @forall s. Applicative (f s)@ context. --- -class - ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT - ) - => FieldGrammar c g | g -> c - where - -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. - blurFieldGrammar :: ALens' a b -> g b d -> g a d - - -- | Field which should be defined, exactly once. - uniqueFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Boolean field with a default value. - booleanFieldDef - :: FieldName -- ^ field name - -> ALens' s Bool -- ^ lens into the field - -> Bool -- ^ default - -> g s Bool - - -- | Optional field. - optionalFieldAla - :: (c b, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) - - -- | Optional field with default value. - optionalFieldDefAla - :: (c b, Newtype a b, Eq a) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'Newtype' pack - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextField - :: FieldName - -> ALens' s (Maybe String) -- ^ lens into the field - -> g s (Maybe String) - - -- | Free text field is essentially 'optionalFieldDefAla` with @""@ - -- as the default and "accept everything" parser. - -- - -- @since 3.0.0.0 - freeTextFieldDef - :: FieldName - -> ALens' s String -- ^ lens into the field - -> g s String - - -- | @since 3.2.0.0 - freeTextFieldDefST - :: FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText - - -- | Monoidal field. - -- - -- Values are combined with 'mappend'. - -- - -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. - -- - monoidalFieldAla - :: (c b, Monoid a, Newtype a b) - => FieldName -- ^ field name - -> (a -> b) -- ^ 'pack' - -> ALens' s a -- ^ lens into the field - -> g s a - - -- | Parser matching all fields with a name starting with a prefix. - prefixedFields - :: FieldName -- ^ field name prefix - -> ALens' s [(String, String)] -- ^ lens into the field - -> g s [(String, String)] - - -- | Known field, which we don't parse, nor pretty print. - knownField :: FieldName -> g s () - - -- | Field which is parsed but not pretty printed. - hiddenField :: g s a -> g s a - - -- | Deprecated since - deprecatedSince - :: CabalSpecVersion -- ^ version - -> String -- ^ deprecation message - -> g s a - -> g s a - - -- | Removed in. If we encounter removed field, parsing fails. - removedIn - :: CabalSpecVersion -- ^ version - -> String -- ^ removal message - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - availableSince - :: CabalSpecVersion -- ^ spec version - -> a -- ^ default value - -> g s a - -> g s a - - -- | Annotate field with since spec-version. - -- This is used to recognise, but warn about the field. - -- It is used to process @other-extensions@ field. - -- - -- Default implementation is to not warn. - -- - -- @since 3.4.0.0 - availableSinceWarn - :: CabalSpecVersion -- ^ spec version - -> g s a - -> g s a - availableSinceWarn _ = id - --- | Field which can be defined at most once. -uniqueField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -uniqueField fn l = uniqueFieldAla fn Identity l - --- | Field which can be defined at most once. -optionalField - :: (FieldGrammar c g, c (Identity a)) - => FieldName -- ^ field name - -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) -optionalField fn l = optionalFieldAla fn Identity l - --- | Optional field with default value. -optionalFieldDef - :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) - => FieldName -- ^ field name - -> ALens' s a -- ^ @'Lens'' s a@: lens into the field - -> a -- ^ default value - -> g s a -optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x - --- | Field which can be define multiple times, and the results are @mappend@ed. -monoidalField - :: (FieldGrammar c g, c (Identity a), Monoid a) - => FieldName -- ^ field name - -> ALens' s a -- ^ lens into the field - -> g s a -monoidalField fn l = monoidalFieldAla fn Identity l - --- | Default implementation for 'freeTextFieldDefST'. -defaultFreeTextFieldDefST - :: (Functor (g s), FieldGrammar c g) - => FieldName - -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText -defaultFreeTextFieldDefST fn l = - toShortText <$> freeTextFieldDef fn (cloneLens l . st) - where - st :: Lens' ShortText String - st f s = toShortText <$> f (fromShortText s) diff --git a/src/Distribution/FieldGrammar/FieldDescrs.hs b/src/Distribution/FieldGrammar/FieldDescrs.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/FieldDescrs.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE UndecidableInstances #-} -module Distribution.FieldGrammar.FieldDescrs ( - FieldDescrs, - fieldDescrPretty, - fieldDescrParse, - fieldDescrsToList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (dropWhileEnd) -import Distribution.Compat.Lens (aview, cloneLens) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.Pretty (Pretty (..), showFreeText) - -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as C -import qualified Distribution.Fields.Field as P -import qualified Distribution.Parsec as P -import qualified Text.PrettyPrint as Disp - --- strict pair -data SP s = SP - { pPretty :: !(s -> Disp.Doc) - , pParse :: !(forall m. P.CabalParsing m => s -> m s) - } - --- | A collection of field parsers and pretty-printers. -newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) } - deriving (Functor) - -instance Applicative (FieldDescrs s) where - pure _ = F mempty - f <*> x = F (mappend (runF f) (runF x)) - -singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a -singletonF fn f g = F $ Map.singleton fn (SP f g) - --- | Lookup a field value pretty-printer. -fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) -fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m - --- | Lookup a field value parser. -fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s) -fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m - -fieldDescrsToList - :: P.CabalParsing m - => FieldDescrs s a - -> [(P.FieldName, s -> Disp.Doc, s -> m s)] -fieldDescrsToList = map mk . Map.toList . runF where - mk (name, SP ppr parse) = (name, ppr, parse) - --- | /Note:/ default values are printed. -instance FieldGrammar ParsecPretty FieldDescrs where - blurFieldGrammar l (F m) = F (fmap blur m) where - blur (SP f g) = SP (f . aview l) (cloneLens l g) - - booleanFieldDef fn l _def = singletonF fn f g where - f s = Disp.text (show (aview l s)) - g s = cloneLens l (const P.parsec) s - -- Note: eta expansion is needed for RankNTypes type-checking to work. - - uniqueFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - optionalFieldAla fn _pack l = singletonF fn f g where - f s = maybe mempty (pretty . pack' _pack) (aview l s) - g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s - - optionalFieldDefAla fn _pack l _def = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s - - freeTextField fn l = singletonF fn f g where - f s = maybe mempty showFreeText (aview l s) - g s = cloneLens l (const (Just <$> parsecFreeText)) s - - freeTextFieldDef fn l = singletonF fn f g where - f s = showFreeText (aview l s) - g s = cloneLens l (const parsecFreeText) s - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = singletonF fn f g where - f s = pretty (pack' _pack (aview l s)) - g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s - - prefixedFields _fnPfx _l = F mempty - knownField _ = pure () - deprecatedSince _ _ x = x - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = F mempty - -parsecFreeText :: P.CabalParsing m => m String -parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar - where - -- Example package with dot lines - -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal - dropDotLines "." = "." - dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x - - dotToEmpty x | trim' x == "." = "" - dotToEmpty x = trim x - - trim' :: String -> String - trim' = dropWhileEnd (`elem` (" \t" :: String)) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -class (P.Parsec a, Pretty a) => ParsecPretty a -instance (P.Parsec a, Pretty a) => ParsecPretty a diff --git a/src/Distribution/FieldGrammar/Newtypes.hs b/src/Distribution/FieldGrammar/Newtypes.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Newtypes.hs +++ /dev/null @@ -1,392 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". -module Distribution.FieldGrammar.Newtypes ( - -- * List - alaList, - alaList', - -- ** Modifiers - CommaVCat (..), - CommaFSep (..), - VCat (..), - FSep (..), - NoCommaFSep (..), - Sep (..), - -- ** Type - List, - -- ** Set - alaSet, - alaSet', - Set', - -- ** NonEmpty - alaNonEmpty, - alaNonEmpty', - NonEmpty', - -- * Version & License - SpecVersion (..), - TestedWith (..), - SpecLicense (..), - -- * Identifiers - Token (..), - Token' (..), - MQuoted (..), - FilePathNT (..), - ) where - -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, - version0, versionNumbers) -import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) - -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX - --- | Vertical list with commas. Displayed with 'vcat' -data CommaVCat = CommaVCat - --- | Paragraph fill list with commas. Displayed with 'fsep' -data CommaFSep = CommaFSep - --- | Vertical list with optional commas. Displayed with 'vcat'. -data VCat = VCat - --- | Paragraph fill list with optional commas. Displayed with 'fsep'. -data FSep = FSep - --- | Paragraph fill list without commas. Displayed with 'fsep'. -data NoCommaFSep = NoCommaFSep - -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc - - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) - -instance Sep CommaVCat where - prettySep _ = vcat . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep CommaFSep where - prettySep _ = fsep . punctuate comma - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p - parseSepNE _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep VCat where - prettySep _ = vcat - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep FSep where - prettySep _ = fsep - parseSep _ p = do - v <- askCabalSpecVersion - if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p - parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep NoCommaFSep where - prettySep _ = fsep - parseSep _ p = many (p <* P.spaces) - parseSepNE _ p = NE.some1 (p <* P.spaces) - --- | List separated with optional commas. Displayed with @sep@, arguments of --- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List { _getList :: [a] } - --- | 'alaList' and 'alaList'' are simply 'List', with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaList VCat --- alaList VCat :: [a] -> List VCat (Identity a) a --- --- >>> :t alaList' FSep Token --- alaList' FSep Token :: [String] -> List FSep Token String --- -alaList :: sep -> [a] -> List sep (Identity a) a -alaList _ = List - --- | More general version of 'alaList'. -alaList' :: sep -> (a -> b) -> [a] -> List sep b a -alaList' _ _ = List - -instance Newtype [a] (List sep wrapper a) - -instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack - --- --- | Like 'List', but for 'Set'. --- --- @since 3.2.0.0 -newtype Set' sep b a = Set' { _getSet :: Set a } - --- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaSet VCat --- alaSet VCat :: Set a -> Set' VCat (Identity a) a --- --- >>> :t alaSet' FSep Token --- alaSet' FSep Token :: Set String -> Set' FSep Token String --- --- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" --- Right (fromList ["bar","foo"]) --- --- @since 3.2.0.0 -alaSet :: sep -> Set a -> Set' sep (Identity a) a -alaSet _ = Set' - --- | More general version of 'alaSet'. --- --- @since 3.2.0.0 -alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a -alaSet' _ _ = Set' - -instance Newtype (Set a) (Set' sep wrapper a) - -instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where - parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack - --- --- | Like 'List', but for 'NonEmpty'. --- --- @since 3.2.0.0 -newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a } - --- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom --- arguments to constrain the resulting type --- --- >>> :t alaNonEmpty VCat --- alaNonEmpty VCat :: NonEmpty a -> NonEmpty' VCat (Identity a) a --- --- >>> unpack' (alaNonEmpty' FSep Token) <$> eitherParsec "foo bar foo" --- Right ("foo" :| ["bar","foo"]) --- --- @since 3.2.0.0 -alaNonEmpty :: sep -> NonEmpty a -> NonEmpty' sep (Identity a) a -alaNonEmpty _ = NonEmpty' - --- | More general version of 'alaNonEmpty'. --- --- @since 3.2.0.0 -alaNonEmpty' :: sep -> (a -> b) -> NonEmpty a -> NonEmpty' sep b a -alaNonEmpty' _ _ = NonEmpty' - -instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) - -instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where - parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec - -instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack - -------------------------------------------------------------------------------- --- Identifiers -------------------------------------------------------------------------------- - --- | Haskell string or @[^ ,]+@ -newtype Token = Token { getToken :: String } - -instance Newtype String Token - -instance Parsec Token where - parsec = pack <$> parsecToken - -instance Pretty Token where - pretty = showToken . unpack - --- | Haskell string or @[^ ]+@ -newtype Token' = Token' { getToken' :: String } - -instance Newtype String Token' - -instance Parsec Token' where - parsec = pack <$> parsecToken' - -instance Pretty Token' where - pretty = showToken . unpack - --- | Either @"quoted"@ or @un-quoted@. -newtype MQuoted a = MQuoted { getMQuoted :: a } - -instance Newtype a (MQuoted a) - -instance Parsec a => Parsec (MQuoted a) where - parsec = pack <$> parsecMaybeQuoted parsec - -instance Pretty a => Pretty (MQuoted a) where - pretty = pretty . unpack - --- | Filepath are parsed as 'Token'. -newtype FilePathNT = FilePathNT { getFilePathNT :: String } - -instance Newtype String FilePathNT - -instance Parsec FilePathNT where - parsec = do - token <- parsecToken - if null token - then P.unexpected "empty FilePath" - else return (FilePathNT token) - -instance Pretty FilePathNT where - pretty = showFilePath . unpack - -------------------------------------------------------------------------------- --- SpecVersion -------------------------------------------------------------------------------- - --- | Version range or just version, i.e. @cabal-version@ field. --- --- There are few things to consider: --- --- * Starting with 2.2 the cabal-version field should be the first field in the --- file and only exact version is accepted. Therefore if we get e.g. --- @>= 2.2@, we fail. --- See --- --- We have this newtype, as writing Parsec and Pretty instances --- for CabalSpecVersion would cause cycle in modules: --- Version -> CabalSpecVersion -> Parsec -> ... --- -newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } - deriving (Eq, Show) -- instances needed for tests - -instance Newtype CabalSpecVersion SpecVersion - -instance Parsec SpecVersion where - parsec = do - e <- parsecSpecVersion - let ver :: Version - ver = either id specVersionFromRange e - - digits :: [Int] - digits = versionNumbers ver - - case cabalSpecFromVersionDigits digits of - Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver - Just csv -> do - -- Check some warnings: - case e of - -- example: cabal-version: 1.10 - -- should be cabal-version: >=1.10 - Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "With 1.10 or earlier, the 'cabal-version' field must use " - , "range syntax rather than a simple version number. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.12 - -- should be cabal-version: 1.12 - Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat - [ "Packages with 'cabal-version: 1.12' or later should specify a " - , "specific version of the Cabal spec of the form " - , "'cabal-version: x.y'. " - , "Use 'cabal-version: " ++ prettyShow ver ++ "'." - ] - - -- example: cabal-version: >=1.10 && <1.12 - -- should be cabal-version: >=1.10 - Right vr | csv < CabalSpecV1_12 - , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat - [ "It is recommended that the 'cabal-version' field only specify a " - , "version range of the form '>= x.y' for older cabal versions. Use " - , "'cabal-version: >= " ++ prettyShow ver ++ "'. " - , "Tools based on Cabal 1.10 and later will ignore upper bounds." - ] - - -- otherwise no warnings - _ -> pure () - - return (pack csv) - where - parsecSpecVersion = Left <$> parsec <|> Right <$> range - - range = do - vr <- parsec - if specVersionFromRange vr >= mkVersion [2,1] - then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" - else return vr - - specVersionFromRange :: VersionRange -> Version - specVersionFromRange versionRange = case asVersionIntervals versionRange of - [] -> version0 - VersionInterval (LowerBound version _) _ : _ -> version - - simpleSpecVersionRangeSyntax = cataVersionRange alg where - alg (OrLaterVersionF _) = True - alg _ = False - - -instance Pretty SpecVersion where - pretty (SpecVersion csv) - | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) - | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) - -------------------------------------------------------------------------------- --- SpecLicense -------------------------------------------------------------------------------- - --- | SPDX License expression or legacy license -newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicense - -instance Parsec SpecLicense where - parsec = do - v <- askCabalSpecVersion - if v >= CabalSpecV2_2 - then SpecLicense . Left <$> parsec - else SpecLicense . Right <$> parsec - -instance Pretty SpecLicense where - pretty = either pretty pretty . unpack - -------------------------------------------------------------------------------- --- TestedWith -------------------------------------------------------------------------------- - --- | Version range or just version -newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } - -instance Newtype (CompilerFlavor, VersionRange) TestedWith - -instance Parsec TestedWith where - parsec = pack <$> parsecTestedWith - -instance Pretty TestedWith where - pretty x = case unpack x of - (compiler, vr) -> pretty compiler <+> pretty vr - -parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) -parsecTestedWith = do - name <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (name, ver) diff --git a/src/Distribution/FieldGrammar/Parsec.hs b/src/Distribution/FieldGrammar/Parsec.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Parsec.hs +++ /dev/null @@ -1,439 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | This module provides a 'FieldGrammarParser', one way to parse --- @.cabal@ -like files. --- --- Fields can be specified multiple times in the .cabal files. The order of --- such entries is important, but the mutual ordering of different fields is --- not.Also conditional sections are considered after non-conditional data. --- The example of this silent-commutation quirk is the fact that --- --- @ --- buildable: True --- if os(linux) --- buildable: False --- @ --- --- and --- --- @ --- if os(linux) --- buildable: False --- buildable: True --- @ --- --- behave the same! This is the limitation of 'GeneralPackageDescription' --- structure. --- --- So we transform the list of fields @['Field' ann]@ into --- a map of grouped ordinary fields and a list of lists of sections: --- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@. --- --- We need list of list of sections, because we need to distinguish situations --- where there are fields in between. For example --- --- @ --- if flag(bytestring-lt-0_10_4) --- build-depends: bytestring < 0.10.4 --- --- default-language: Haskell2020 --- --- else --- build-depends: bytestring >= 0.10.4 --- --- @ --- --- is obviously invalid specification. --- --- We can parse 'Fields' like we parse @aeson@ objects, yet we use --- slightly higher-level API, so we can process unspecified fields, --- to report unknown fields and save custom @x-fields@. --- -module Distribution.FieldGrammar.Parsec ( - ParsecFieldGrammar, - parseFieldGrammar, - fieldGrammarKnownFieldList, - -- * Auxiliary - Fields, - NamelessField (..), - namelessFieldAnn, - Section (..), - runFieldParser, - runFieldParser', - fieldLinesToStream, - ) where - -import Data.List (dropWhileEnd) -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Simple.Utils (fromUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Utils.ShortText as ShortText -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - -import Distribution.CabalSpecVersion -import Distribution.FieldGrammar.Class -import Distribution.Fields.Field -import Distribution.Fields.ParseResult -import Distribution.Parsec -import Distribution.Parsec.FieldLineStream -import Distribution.Parsec.Position (positionCol, positionRow) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -type Fields ann = Map FieldName [NamelessField ann] - --- | Single field, without name, but with its annotation. -data NamelessField ann = MkNamelessField !ann [FieldLine ann] - deriving (Eq, Show, Functor) - -namelessFieldAnn :: NamelessField ann -> ann -namelessFieldAnn (MkNamelessField ann _) = ann - --- | The 'Section' constructor of 'Field'. -data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor) - -------------------------------------------------------------------------------- --- ParsecFieldGrammar -------------------------------------------------------------------------------- - -data ParsecFieldGrammar s a = ParsecFG - { fieldGrammarKnownFields :: !(Set FieldName) - , fieldGrammarKnownPrefixes :: !(Set FieldName) - , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a) - } - deriving (Functor) - -parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a -parseFieldGrammar v fields grammar = do - for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) -> - for_ nfields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - -- TODO: fields allowed in this section - - -- parse - fieldGrammarParser grammar v fields - - where - isUnknownField k _ = not $ - k `Set.member` fieldGrammarKnownFields grammar - || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) - -fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] -fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields - -instance Applicative (ParsecFieldGrammar s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) - {-# INLINE pure #-} - - ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG - (mappend f x) - (mappend f' x') - (\v fields -> f'' v fields <*> x'' v fields) - {-# INLINE (<*>) #-} - -warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult () -warnMultipleSingularFields _ [] = pure () -warnMultipleSingularFields fn (x : xs) = do - let pos = namelessFieldAnn x - poss = map namelessFieldAnn xs - parseWarning pos PWTMultipleSingularField $ - "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) - -instance FieldGrammar Parsec ParsecFieldGrammar where - blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser - - uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = - unpack' _pack <$> runFieldParser pos parsec v fls - - booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls - - optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure def - Just [] -> pure def - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure def - | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls - - freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure Nothing - Just [] -> pure Nothing - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure Nothing - | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls)) - | otherwise = pure (Just (fieldlinesToFreeText fls)) - - freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure "" - Just [] -> pure "" - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) - | null fls = pure "" - | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls) - | otherwise = pure (fieldlinesToFreeText fls) - - -- freeTextFieldDefST = defaultFreeTextFieldDefST - freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just [] -> pure mempty - Just [x] -> parseOne v x - Just xs@(_:y:ys) -> do - warnMultipleSingularFields fn xs - NE.last <$> traverse (parseOne v) (y:|ys) - - parseOne v (MkNamelessField pos fls) = case fls of - [] -> pure mempty - [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) - _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) - | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) - - monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs - - parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) - where - parser :: Fields Position -> [(String, String)] - parser values = reorder $ concatMap convert $ filter match $ Map.toList values - - match (fn, _) = fnPfx `BS.isPrefixOf` fn - convert (fn, fields) = - [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) - | MkNamelessField pos fls <- fields - ] - -- hack: recover the order of prefixed fields - reorder = map snd . sortBy (comparing fst) - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - - availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." - - pure def - - availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = parser v values - | otherwise = do - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList unknownFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTUnknownField $ - "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." - - parser v values - - - -- todo we know about this field - deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' - where - parser' v values - | v >= vs = do - let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names - for_ (Map.toList deprecatedFields) $ \(name, fields) -> - for_ fields $ \(MkNamelessField pos _) -> - parseWarning pos PWTDeprecatedField $ - "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg - - parser v values - - | otherwise = parser v values - - removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = do - let msg' = if null msg then "" else ' ' : msg - let unknownFields = Map.intersection values $ Map.fromSet (const ()) names - let namePos = - [ (name, pos) - | (name, fields) <- Map.toList unknownFields - , MkNamelessField pos _ <- fields - ] - - let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' - - case namePos of - -- no fields => proceed (with empty values, to be sure) - [] -> parser v mempty - - -- if there's single field: fail fatally with it - ((name, pos) : rest) -> do - for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' - parseFatalFailure pos $ makeMsg name - - | otherwise = parser v values - - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) - - hiddenField = id - -------------------------------------------------------------------------------- --- Parsec -------------------------------------------------------------------------------- - -runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a -runFieldParser' inputPoss p v str = case P.runParser p' [] "" str of - Right (pok, ws) -> do - traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws - pure pok - Left err -> do - let ppos = P.errorPos err - let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos) - - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFatalFailure epos $ msg ++ "\n" - where - p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState - - -- Positions start from 1:1, not 0:0 - mapPosition (Position prow pcol) = go (prow - 1) inputPoss where - go _ [] = zeroPos - go _ [Position row col] = Position row (col + pcol - 1) - go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1) - go n (_:ps) = go (n - 1) ps - -runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a -runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls) - where - poss = map (\(FieldLine pos _) -> pos) ls ++ [pp] -- add "default" position - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Example package with dot lines --- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal -fieldlinesToFreeText :: [FieldLine ann] -> String -fieldlinesToFreeText [FieldLine _ "."] = "." -fieldlinesToFreeText fls = intercalate "\n" (map go fls) - where - go (FieldLine _ bs) - | s == "." = "" - | otherwise = s - where - s = trim (fromUTF8BS bs) - - trim :: String -> String - trim = dropWhile isSpace . dropWhileEnd isSpace - -fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String -fieldlinesToFreeText3 _ [] = "" -fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs -fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _)) - -- if first line is on the same line with field name: - -- the indentation level is either - -- 1. the indentation of left most line in rest fields - -- 2. the indentation of the first line - -- whichever is leftmost - | positionRow pos == positionRow pos1 = concat - $ fromUTF8BS bs1 - : mealy (mk mcol1) pos1 fls2 - - -- otherwise, also indent the first line - | otherwise = concat - $ replicate (positionCol pos1 - mcol2) ' ' - : fromUTF8BS bs1 - : mealy (mk mcol2) pos1 fls2 - - where - mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2 - mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2 - - mk :: Int -> Position -> FieldLine Position -> (Position, String) - mk col p (FieldLine q bs) = - ( q - , replicate newlines '\n' - ++ replicate indent ' ' - ++ fromUTF8BS bs - ) - where - newlines = positionRow q - positionRow p - indent = positionCol q - col - -mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b] -mealy f = go where - go _ [] = [] - go s (x : xs) = let ~(s', y) = f s x in y : go s' xs - -fieldLinesToStream :: [FieldLine ann] -> FieldLineStream -fieldLinesToStream [] = fieldLineStreamEnd -fieldLinesToStream [FieldLine _ bs] = FLSLast bs -fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) diff --git a/src/Distribution/FieldGrammar/Pretty.hs b/src/Distribution/FieldGrammar/Pretty.hs deleted file mode 100644 --- a/src/Distribution/FieldGrammar/Pretty.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Distribution.FieldGrammar.Pretty ( - PrettyFieldGrammar, - prettyFieldGrammar, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compat.Newtype -import Distribution.Compat.Prelude -import Distribution.Fields.Field (FieldName) -import Distribution.Fields.Pretty (PrettyField (..)) -import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) -import Distribution.Simple.Utils (toUTF8BS) -import Prelude () -import Text.PrettyPrint (Doc) -import qualified Text.PrettyPrint as PP - -import Distribution.FieldGrammar.Class - -newtype PrettyFieldGrammar s a = PrettyFG - { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] - } - deriving (Functor) - -instance Applicative (PrettyFieldGrammar s) where - pure _ = PrettyFG (\_ _ -> mempty) - PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) - --- | We can use 'PrettyFieldGrammar' to pp print the @s@. --- --- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()] -prettyFieldGrammar = flip fieldGrammarPretty - -instance FieldGrammar Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) - - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> - ppField fn (pretty (pack' _pack (aview l s))) - - booleanFieldDef fn l def = PrettyFG pp - where - pp _v s - | b == def = mempty - | otherwise = ppField fn (PP.text (show b)) - where - b = aview l s - - optionalFieldAla fn _pack l = PrettyFG pp - where - pp v s = case aview l s of - Nothing -> mempty - Just a -> ppField fn (prettyVersioned v (pack' _pack a)) - - optionalFieldDefAla fn _pack l def = PrettyFG pp - where - pp v s - | x == def = mempty - | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) - where - x = aview l s - - freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppField fn . showFT) (aview l s) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - -- it's ok to just show, as showFreeText of empty string is empty. - freeTextFieldDef fn l = PrettyFG pp where - pp v s = ppField fn (showFT (aview l s)) where - showFT | v >= CabalSpecV3_0 = showFreeTextV3 - | otherwise = showFreeText - - freeTextFieldDefST = defaultFreeTextFieldDefST - - monoidalFieldAla fn _pack l = PrettyFG pp - where - pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) - where - pp xs = - -- always print the field, even its Doc is empty. - -- i.e. don't use ppField - [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s - | (n, s) <- xs - -- fnPfx `isPrefixOf` n - ] - - knownField _ = pure () - deprecatedSince _ _ x = x - -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field - -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed - -- so invalid documents can be only manually constructed. - removedIn _ _ x = x - availableSince _ _ = id - hiddenField _ = PrettyFG (\_ -> mempty) - -ppField :: FieldName -> Doc -> [PrettyField ()] -ppField name fielddoc - | PP.isEmpty fielddoc = [] - | otherwise = [ PrettyField () name fielddoc ] diff --git a/src/Distribution/Fields.hs b/src/Distribution/Fields.hs deleted file mode 100644 --- a/src/Distribution/Fields.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Utilitiies to work with @.cabal@ like file structure. -module Distribution.Fields ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - FieldName, - -- * Grammar and parsing - -- - -- See "Distribution.Fields.Parser" for grammar. - readFields, - readFields', - -- ** ParseResult - ParseResult, - runParseResult, - parseString, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Pretty printing - PrettyField (..), - showFields, - -- ** Transformation from Field - genericFromParsecFields, - fromParsecFields, - ) where - -import Distribution.Fields.Field -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.Fields.Pretty -import Distribution.Parsec.Error -import Distribution.Parsec.Warning diff --git a/src/Distribution/Fields/ConfVar.hs b/src/Distribution/Fields/ConfVar.hs deleted file mode 100644 --- a/src/Distribution/Fields/ConfVar.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Fields.ConfVar (parseConditionConfVar) where - -import Distribution.Compat.CharParsing (char, integral) -import Distribution.Compat.Prelude -import Distribution.Fields.Field (SectionArg (..)) -import Distribution.Fields.ParseResult -import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Types.Condition -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Version - (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion, - mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges, - withinVersion) -import Prelude () - -import qualified Text.Parsec as P -import qualified Text.Parsec.Error as P - --- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec --- based outline parser. -parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar) -parseConditionConfVar args = - -- The name of the input file is irrelevant, as we reformat the error message. - case P.runParser (parser <* P.eof) () "" args of - Right x -> pure x - Left err -> do - -- Mangle the position to the actual one - let ppos = P.errorPos err - let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - let msg = P.showErrorMessages - "or" "unknown parse error" "expecting" "unexpected" "end of input" - (P.errorMessages err) - parseFailure epos msg - pure $ Lit True - -type Parser = P.Parsec [SectionArg Position] () - -sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a) -sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) - -parser :: Parser (Condition ConfVar) -parser = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd - cond = P.choice - [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ] - - notCond = CNot <$ oper "!" <*> cond - - boolLiteral = Lit <$> boolLiteral' - osCond = Var . OS <$ string "os" <*> parens fromParsec - flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec - archCond = Var . Arch <$ string "arch" <*> parens fromParsec - implCond = Var <$ string "impl" <*> parens implCond' - - implCond' = Impl - <$> fromParsec - <*> P.option anyVersion versionRange - - version = fromParsec - versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*" - versionStar' = some (integral <* char '.') - - versionRange = expr - where - expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||") - term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&") - - factor = P.choice - $ parens expr - : parseAnyVersion - : parseNoVersion - : parseWildcardRange - : map parseRangeOp rangeOps - - parseAnyVersion = anyVersion <$ string "-any" - parseNoVersion = noVersion <$ string "-none" - - parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar - - parseRangeOp (s,f) = P.try (f <$ oper s <*> version) - rangeOps = [ ("<", earlierVersion), - ("<=", orEarlierVersion), - (">", laterVersion), - (">=", orLaterVersion), - ("^>=", majorBoundVersion), - ("==", thisVersion) ] - - -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1" - identBS = tokenPrim $ \t -> case t of - SecArgName _ s -> Just s - _ -> Nothing - - boolLiteral' = tokenPrim $ \t -> case t of - SecArgName _ s - | s == "True" -> Just True - | s == "true" -> Just True - | s == "False" -> Just False - | s == "false" -> Just False - _ -> Nothing - - string s = tokenPrim $ \t -> case t of - SecArgName _ s' | s == s' -> Just () - _ -> Nothing - - oper o = tokenPrim $ \t -> case t of - SecArgOther _ o' | o == o' -> Just () - _ -> Nothing - - parens = P.between (oper "(") (oper ")") - - tokenPrim = P.tokenPrim prettySectionArg updatePosition - -- TODO: check where the errors are reported - updatePosition x _ _ = x - prettySectionArg = show - - fromParsec :: Parsec a => Parser a - fromParsec = fromParsec' parsec - - fromParsec' p = do - bs <- identBS - let fls = fieldLineStreamFromBS bs - either (fail . show) pure (runParsecParser p "" fls) diff --git a/src/Distribution/Fields/Field.hs b/src/Distribution/Fields/Field.hs deleted file mode 100644 --- a/src/Distribution/Fields/Field.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc --- --- These types are parametrized by an annotation. -module Distribution.Fields.Field ( - -- * Cabal file - Field (..), - fieldName, - fieldAnn, - fieldUniverse, - FieldLine (..), - fieldLineAnn, - fieldLineBS, - SectionArg (..), - sectionArgAnn, - -- * Name - FieldName, - Name (..), - mkName, - getName, - nameAnn, - -- * Conversions to String - sectionArgsToString, - fieldLinesToString, - ) where - -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as Char -import Distribution.Compat.Prelude -import Distribution.Pretty (showTokenStr) -import Distribution.Simple.Utils (fromUTF8BS) -import Prelude () - - -------------------------------------------------------------------------------- --- Cabal file -------------------------------------------------------------------------------- - --- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@). -data Field ann - = Field !(Name ann) [FieldLine ann] - | Section !(Name ann) [SectionArg ann] [Field ann] - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Section of field name -fieldName :: Field ann -> Name ann -fieldName (Field n _ ) = n -fieldName (Section n _ _) = n - -fieldAnn :: Field ann -> ann -fieldAnn = nameAnn . fieldName - --- | All transitive descendants of 'Field', including itself. --- --- /Note:/ the resulting list is never empty. --- -fieldUniverse :: Field ann -> [Field ann] -fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs -fieldUniverse f@(Field _ _) = [f] - --- | A line of text representing the value of a field from a Cabal file. --- A field may contain multiple lines. --- --- /Invariant:/ 'ByteString' has no newlines. -data FieldLine ann = FieldLine !ann !ByteString - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | @since 3.0.0.0 -fieldLineAnn :: FieldLine ann -> ann -fieldLineAnn (FieldLine ann _) = ann - --- | @since 3.0.0.0 -fieldLineBS :: FieldLine ann -> ByteString -fieldLineBS (FieldLine _ bs) = bs - --- | Section arguments, e.g. name of the library -data SectionArg ann - = SecArgName !ann !ByteString - -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3" - | SecArgStr !ann !ByteString - -- ^ quoted string - | SecArgOther !ann !ByteString - -- ^ everything else, mm. operators (e.g. in if-section conditionals) - deriving (Eq, Show, Functor, Foldable, Traversable) - --- | Extract annotation from 'SectionArg'. -sectionArgAnn :: SectionArg ann -> ann -sectionArgAnn (SecArgName ann _) = ann -sectionArgAnn (SecArgStr ann _) = ann -sectionArgAnn (SecArgOther ann _) = ann - -------------------------------------------------------------------------------- --- Name -------------------------------------------------------------------------------- - -type FieldName = ByteString - --- | A field name. --- --- /Invariant/: 'ByteString' is lower-case ASCII. -data Name ann = Name !ann !FieldName - deriving (Eq, Show, Functor, Foldable, Traversable) - -mkName :: ann -> FieldName -> Name ann -mkName ann bs = Name ann (B.map Char.toLower bs) - -getName :: Name ann -> FieldName -getName (Name _ bs) = bs - -nameAnn :: Name ann -> ann -nameAnn (Name ann _) = ann - -------------------------------------------------------------------------------- --- To Strings -------------------------------------------------------------------------------- - --- | --- --- @since 3.6.0.0 -sectionArgsToString :: [SectionArg ann] -> String -sectionArgsToString = unwords . map toStr where - toStr :: SectionArg ann -> String - toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs) - toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs) - toStr (SecArgOther _ bs) = fromUTF8BS bs - --- | Convert @['FieldLine']@ into String. --- --- /Note:/ this doesn't preserve indentation or empty lines, --- as the annotations (e.g. positions) are ignored. --- --- @since 3.6.0.0 -fieldLinesToString :: [FieldLine ann] -> String -fieldLinesToString = - -- intercalate to avoid trailing newline. - intercalate "\n" . map toStr - where - toStr (FieldLine _ bs) = fromUTF8BS bs diff --git a/src/Distribution/Fields/Lexer.hs b/src/Distribution/Fields/Lexer.hs deleted file mode 100644 --- a/src/Distribution/Fields/Lexer.hs +++ /dev/null @@ -1,496 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} -{-# LANGUAGE CPP,MagicHash #-} -{-# LINE 1 "templates/Lexer.x" #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Lexer --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Lexer for the cabal files. -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -#ifdef CABAL_PARSEC_DEBUG -{-# LANGUAGE PatternGuards #-} -#endif -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Distribution.Fields.Lexer - (ltest, lexToken, Token(..), LToken(..) - ,bol_section, in_section, in_field_layout, in_field_braces - ,mkLexState) where - --- [Note: boostrapping parsec parser] --- --- We manually produce the `Lexer.hs` file from `boot/Lexer.x` (make lexer) --- because boostrapping cabal-install would be otherwise tricky. --- Alex is (atm) tricky package to build, cabal-install has some magic --- to move bundled generated files in place, so rather we don't depend --- on it before we can build it ourselves. --- Therefore there is one thing less to worry in bootstrap.sh, which is a win. --- --- See also https://github.com/haskell/cabal/issues/4633 --- - -import Prelude () -import qualified Prelude as Prelude -import Distribution.Compat.Prelude - -import Distribution.Fields.LexerMonad -import Distribution.Parsec.Position (Position (..), incPos, retPos) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B.Char8 -import qualified Data.Word as Word - -#ifdef CABAL_PARSEC_DEBUG -import Debug.Trace -import qualified Data.Vector as V -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - -#if __GLASGOW_HASKELL__ >= 603 -#include "ghcconfig.h" -#elif defined(__GLASGOW_HASKELL__) -#include "config.h" -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array -#else -import Array -#endif -#if __GLASGOW_HASKELL__ >= 503 -import Data.Array.Base (unsafeAt) -import GHC.Exts -#else -import GlaExts -#endif -alex_tab_size :: Int -alex_tab_size = 8 -alex_base :: AlexAddr -alex_base = AlexA# - "\x12\xff\xff\xff\xf9\xff\xff\xff\xfb\xff\xff\xff\x01\x00\x00\x00\x2f\x00\x00\x00\x50\x00\x00\x00\xd0\x00\x00\x00\x48\xff\xff\xff\xdc\xff\xff\xff\x51\xff\xff\xff\x6d\xff\xff\xff\x6f\xff\xff\xff\x50\x01\x00\x00\x74\x01\x00\x00\x70\xff\xff\xff\x68\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\xa3\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\xd1\x01\x00\x00\xfb\x01\x00\x00\x7b\x02\x00\x00\xfb\x02\x00\x00\x00\x00\x00\x00\x7b\x03\x00\x00\x7d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x6d\x00\x00\x00\x6b\x00\x00\x00\xfc\x03\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x6f\x00\x00\x00\x1c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00"# - -alex_table :: AlexAddr -alex_table = AlexA# - "\x00\x00\x09\x00\x0f\x00\x11\x00\x02\x00\x11\x00\x12\x00\x00\x00\x12\x00\x13\x00\x03\x00\x11\x00\x07\x00\x10\x00\x12\x00\x25\x00\x14\x00\x11\x00\x10\x00\x11\x00\x14\x00\x11\x00\x12\x00\x23\x00\x12\x00\x0f\x00\x28\x00\x02\x00\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x08\x00\x10\x00\x00\x00\x14\x00\x00\x00\x00\x00\x08\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x2e\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x28\x00\xff\xff\xff\xff\x29\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x26\x00\x0f\x00\x11\x00\x17\x00\x26\x00\x12\x00\x25\x00\x11\x00\x2a\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x17\x00\x26\x00\x00\x00\x25\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x0e\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x23\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\x1e\x00\x0d\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x1f\x00\x1f\x00\x1e\x00\x1e\x00\x1e\x00\x19\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x1f\x00\x1e\x00\x1f\x00\x1e\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x1e\x00\x22\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1d\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\xff\xff\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x18\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\xff\xff\xff\xff\x1e\x00\x1e\x00\x1e\x00\x1a\x00\x1a\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x1c\x00\x1e\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1e\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\xff\xff\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - -alex_check :: AlexAddr -alex_check = AlexA# - "\xff\xff\xef\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\xbf\x00\x0d\x00\x2d\x00\x09\x00\x0a\x00\xbb\x00\xa0\x00\x0d\x00\xa0\x00\xa0\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x0d\x00\x0a\x00\x0d\x00\x20\x00\x0a\x00\x20\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\x2d\x00\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\x2d\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x09\x00\x0a\x00\x09\x00\x09\x00\x0d\x00\x09\x00\x0a\x00\x09\x00\xff\xff\x0d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xff\xff\xc2\x00\xff\xff\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x5c\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x5c\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x7f\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7f\x00\x7e\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_deflt :: AlexAddr -alex_deflt = AlexA# - "\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\x27\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x18\x00\x1b\x00\x1b\x00\x1b\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\xff\xff"# - -alex_accept = listArray (0 :: Int, 47) - [ AlexAcc 29 - , AlexAcc 28 - , AlexAcc 27 - , AlexAcc 26 - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAccNone - , AlexAcc 25 - , AlexAcc 24 - , AlexAccSkip - , AlexAcc 23 - , AlexAcc 22 - , AlexAcc 21 - , AlexAccSkip - , AlexAccSkip - , AlexAcc 20 - , AlexAcc 19 - , AlexAcc 18 - , AlexAcc 17 - , AlexAcc 16 - , AlexAcc 15 - , AlexAcc 14 - , AlexAcc 13 - , AlexAcc 12 - , AlexAcc 11 - , AlexAcc 10 - , AlexAcc 9 - , AlexAcc 8 - , AlexAccSkip - , AlexAcc 7 - , AlexAcc 6 - , AlexAcc 5 - , AlexAccSkip - , AlexAcc 4 - , AlexAcc 3 - , AlexAcc 2 - , AlexAcc 1 - , AlexAcc 0 - ] - -alex_actions = array (0 :: Int, 30) - [ (29,alex_action_0) - , (28,alex_action_20) - , (27,alex_action_16) - , (26,alex_action_3) - , (25,alex_action_1) - , (24,alex_action_1) - , (23,alex_action_3) - , (22,alex_action_4) - , (21,alex_action_5) - , (20,alex_action_8) - , (19,alex_action_8) - , (18,alex_action_8) - , (17,alex_action_9) - , (16,alex_action_9) - , (15,alex_action_10) - , (14,alex_action_11) - , (13,alex_action_12) - , (12,alex_action_13) - , (11,alex_action_14) - , (10,alex_action_15) - , (9,alex_action_15) - , (8,alex_action_16) - , (7,alex_action_18) - , (6,alex_action_19) - , (5,alex_action_19) - , (4,alex_action_22) - , (3,alex_action_23) - , (2,alex_action_24) - , (1,alex_action_25) - , (0,alex_action_25) - ] - -{-# LINE 151 "templates/Lexer.x" #-} - --- | Tokens of outer cabal file structure. Field values are treated opaquely. -data Token = TokSym !ByteString -- ^ Haskell-like identifier, number or operator - | TokStr !ByteString -- ^ String in quotes - | TokOther !ByteString -- ^ Operators and parens - | Indent !Int -- ^ Indentation token - | TokFieldLine !ByteString -- ^ Lines after @:@ - | Colon - | OpenBrace - | CloseBrace - | EOF - | LexicalError InputStream --TODO: add separate string lexical error - deriving Show - -data LToken = L !Position !Token - deriving Show - -toki :: (ByteString -> Token) -> Position -> Int -> ByteString -> Lex LToken -toki t pos len input = return $! L pos (t (B.take len input)) - -tok :: Token -> Position -> Int -> ByteString -> Lex LToken -tok t pos _len _input = return $! L pos t - -checkLeadingWhitespace :: Int -> ByteString -> Lex Int -checkLeadingWhitespace len bs - | B.any (== 9) (B.take len bs) = do - addWarning LexWarningTab - checkWhitespace len bs - | otherwise = checkWhitespace len bs - -checkWhitespace :: Int -> ByteString -> Lex Int -checkWhitespace len bs - | B.any (== 194) (B.take len bs) = do - addWarning LexWarningNBSP - return $ len - B.count 194 (B.take len bs) - | otherwise = return len - --- ----------------------------------------------------------------------------- --- The input type - -type AlexInput = InputStream - -alexInputPrevChar :: AlexInput -> Char -alexInputPrevChar _ = error "alexInputPrevChar not used" - -alexGetByte :: AlexInput -> Maybe (Word.Word8,AlexInput) -alexGetByte = B.uncons - -lexicalError :: Position -> InputStream -> Lex LToken -lexicalError pos inp = do - setInput B.empty - return $! L pos (LexicalError inp) - -lexToken :: Lex LToken -lexToken = do - pos <- getPos - inp <- getInput - st <- getStartCode - case alexScan inp st of - AlexEOF -> return (L pos EOF) - AlexError inp' -> - let !len_bytes = B.length inp - B.length inp' in - --FIXME: we want len_chars here really - -- need to decode utf8 up to this point - lexicalError (incPos len_bytes pos) inp' - AlexSkip inp' len_chars -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - lexToken - AlexToken inp' len_chars action -> do - checkPosition pos inp inp' len_chars - adjustPos (incPos len_chars) - setInput inp' - let !len_bytes = B.length inp - B.length inp' - t <- action pos len_bytes inp - --traceShow t $ return tok - return t - -checkPosition :: Position -> ByteString -> ByteString -> Int -> Lex () -#ifdef CABAL_PARSEC_DEBUG -checkPosition pos@(Position lineno colno) inp inp' len_chars = do - text_lines <- getDbgText - let len_bytes = B.length inp - B.length inp' - pos_txt | lineno-1 < V.length text_lines = T.take len_chars (T.drop (colno-1) (text_lines V.! (lineno-1))) - | otherwise = T.empty - real_txt = B.take len_bytes inp - when (pos_txt /= T.decodeUtf8 real_txt) $ - traceShow (pos, pos_txt, T.decodeUtf8 real_txt) $ - traceShow (take 3 (V.toList text_lines)) $ return () - where - getDbgText = Lex $ \s@LexState{ dbgText = txt } -> LexResult s txt -#else -checkPosition _ _ _ _ = return () -#endif - -lexAll :: Lex [LToken] -lexAll = do - t <- lexToken - case t of - L _ EOF -> return [t] - _ -> do ts <- lexAll - return (t : ts) - -ltest :: Int -> String -> Prelude.IO () -ltest code s = - let (ws, xs) = execLexer (setStartCode code >> lexAll) (B.Char8.pack s) - in traverse_ print ws >> traverse_ print xs - -mkLexState :: ByteString -> LexState -mkLexState input = LexState - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . lines' . T.decodeUtf8With T.lenientDecode $ input -#endif - } - -#ifdef CABAL_PARSEC_DEBUG -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l `T.snoc` '\r' `T.snoc` '\n' : lines' s4 - _ -> l `T.snoc` c : lines' s3 - - | otherwise - -> [l] -#endif - -bol_field_braces,bol_field_layout,bol_section,in_field_braces,in_field_layout,in_section :: Int -bol_field_braces = 1 -bol_field_layout = 2 -bol_section = 3 -in_field_braces = 4 -in_field_layout = 5 -in_section = 6 -alex_action_0 = \_ len _ -> do - when (len /= 0) $ addWarning LexWarningBOM - setStartCode bol_section - lexToken - -alex_action_1 = \_pos len inp -> checkWhitespace len inp >> adjustPos retPos >> lexToken -alex_action_3 = \pos len inp -> checkLeadingWhitespace len inp >> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_section - >> return (L pos (Indent len)) -alex_action_4 = tok OpenBrace -alex_action_5 = tok CloseBrace -alex_action_8 = toki TokSym -alex_action_9 = \pos len inp -> return $! L pos (TokStr (B.take (len - 2) (B.tail inp))) -alex_action_10 = toki TokOther -alex_action_11 = toki TokOther -alex_action_12 = tok Colon -alex_action_13 = tok OpenBrace -alex_action_14 = tok CloseBrace -alex_action_15 = \_ _ _ -> adjustPos retPos >> setStartCode bol_section >> lexToken -alex_action_16 = \pos len inp -> checkLeadingWhitespace len inp >>= \len' -> - if B.length inp == len - then return (L pos EOF) - else setStartCode in_field_layout - >> return (L pos (Indent len')) -alex_action_18 = toki TokFieldLine -alex_action_19 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_layout >> lexToken -alex_action_20 = \_ _ _ -> setStartCode in_field_braces >> lexToken -alex_action_22 = toki TokFieldLine -alex_action_23 = tok OpenBrace -alex_action_24 = tok CloseBrace -alex_action_25 = \_ _ _ -> adjustPos retPos >> setStartCode bol_field_braces >> lexToken -{-# LINE 1 "templates/GenericTemplate.hs" #-} --- ----------------------------------------------------------------------------- --- ALEX TEMPLATE --- --- This code is in the PUBLIC DOMAIN; you may copy it freely and use --- it for any purpose whatsoever. - --- ----------------------------------------------------------------------------- --- INTERNALS and main scanner engine - --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ > 706 -#define GTE(n,m) (tagToEnum# (n >=# m)) -#define EQ(n,m) (tagToEnum# (n ==# m)) -#else -#define GTE(n,m) (n >=# m) -#define EQ(n,m) (n ==# m) -#endif - -data AlexAddr = AlexA# Addr# --- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -#if __GLASGOW_HASKELL__ < 503 -uncheckedShiftL# = shiftL# -#endif - -{-# INLINE alexIndexInt16OffAddr #-} -alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt16OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow16Int# i - where - i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) - high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - low = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 2# -#else -#if __GLASGOW_HASKELL__ >= 901 - int16ToInt# -#endif - (indexInt16OffAddr# arr off) -#endif - -{-# INLINE alexIndexInt32OffAddr #-} -alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int# -alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN - narrow32Int# i - where - i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` - (b2 `uncheckedShiftL#` 16#) `or#` - (b1 `uncheckedShiftL#` 8#) `or#` b0) - b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) - b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) - b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) - b0 = int2Word# (ord# (indexCharOffAddr# arr off')) - off' = off *# 4# -#else -#if __GLASGOW_HASKELL__ >= 901 - int32ToInt# -#endif - (indexInt32OffAddr# arr off) -#endif - -#if __GLASGOW_HASKELL__ < 503 -quickIndex arr i = arr ! i -#else --- GHC >= 503, unsafeAt is available from Data.Array.Base. -quickIndex = unsafeAt -#endif - --- ----------------------------------------------------------------------------- --- Main lexing routines - -data AlexReturn a - = AlexEOF - | AlexError !AlexInput - | AlexSkip !AlexInput !Int - | AlexToken !AlexInput !Int a - --- alexScan :: AlexInput -> StartCode -> AlexReturn a -alexScan input__ (I# (sc)) - = alexScanUser undefined input__ (I# (sc)) - -alexScanUser user__ input__ (I# (sc)) - = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of - (AlexNone, input__') -> - case alexGetByte input__ of - Nothing -> - - AlexEOF - Just _ -> - - AlexError input__' - - (AlexLastSkip input__'' len, _) -> - - AlexSkip input__'' len - - (AlexLastAcc k input__''' len, _) -> - - AlexToken input__''' len (alex_actions ! k) - --- Push the input through the DFA, remembering the most recent accepting --- state it encountered. - -alex_scan_tkn user__ orig_input len input__ s last_acc = - input__ `seq` -- strict in the input - let - new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) - in - new_acc `seq` - case alexGetByte input__ of - Nothing -> (new_acc, input__) - Just (c, new_input) -> - - case fromIntegral c of { (I# (ord_c)) -> - let - base = alexIndexInt32OffAddr alex_base s - offset = (base +# ord_c) - check = alexIndexInt16OffAddr alex_check offset - - new_s = if GTE(offset,0#) && EQ(check,ord_c) - then alexIndexInt16OffAddr alex_table offset - else alexIndexInt16OffAddr alex_deflt s - in - case new_s of - -1# -> (new_acc, input__) - -- on an error, we want to keep the input *before* the - -- character that failed, not after. - _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) - -- note that the length is increased ONLY if this is the 1st byte in a char encoding) - new_input new_s new_acc - } - where - check_accs (AlexAccNone) = last_acc - check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) - check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) - -data AlexLastAcc - = AlexNone - | AlexLastAcc !Int !AlexInput !Int - | AlexLastSkip !AlexInput !Int - -data AlexAcc user - = AlexAccNone - | AlexAcc Int - | AlexAccSkip - diff --git a/src/Distribution/Fields/LexerMonad.hs b/src/Distribution/Fields/LexerMonad.hs deleted file mode 100644 --- a/src/Distribution/Fields/LexerMonad.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.LexerMonad --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.LexerMonad ( - InputStream, - LexState(..), - LexResult(..), - - Lex(..), - execLexer, - - getPos, - setPos, - adjustPos, - - getInput, - setInput, - - getStartCode, - setStartCode, - - LexWarning(..), - LexWarningType(..), - addWarning, - toPWarnings, - - ) where - -import qualified Data.ByteString as B -import qualified Data.List.NonEmpty as NE -import Distribution.Compat.Prelude -import Distribution.Parsec.Position (Position (..), showPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..)) -import Prelude () - -import qualified Data.Map.Strict as Map - -#ifdef CABAL_PARSEC_DEBUG --- testing only: -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -#endif - --- simple state monad -newtype Lex a = Lex { unLex :: LexState -> LexResult a } - -instance Functor Lex where - fmap = liftM - -instance Applicative Lex where - pure = returnLex - (<*>) = ap - -instance Monad Lex where - return = pure - (>>=) = thenLex - -data LexResult a = LexResult {-# UNPACK #-} !LexState a - -data LexWarningType - = LexWarningNBSP -- ^ Encountered non breaking space - | LexWarningBOM -- ^ BOM at the start of the cabal file - | LexWarningTab -- ^ Leading tags - deriving (Eq, Ord, Show) - -data LexWarning = LexWarning !LexWarningType - {-# UNPACK #-} !Position - deriving (Show) - -toPWarnings :: [LexWarning] -> [PWarning] -toPWarnings - = map (uncurry toWarning) - . Map.toList - . Map.fromListWith (<>) - . map (\(LexWarning t p) -> (t, pure p)) - where - toWarning LexWarningBOM poss = - PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file" - toWarning LexWarningNBSP poss = - PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - toWarning LexWarningTab poss = - PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss) - -data LexState = LexState { - curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location - curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input - curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code - warnings :: [LexWarning] -#ifdef CABAL_PARSEC_DEBUG - , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info -#endif - } --TODO: check if we should cache the first token - -- since it looks like parsec's uncons can be called many times on the same input - -type StartCode = Int -- ^ An @alex@ lexer start code -type InputStream = B.ByteString - - - --- | Execute the given lexer on the supplied input stream. -execLexer :: Lex a -> InputStream -> ([LexWarning], a) -execLexer (Lex lexer) input = - case lexer initialState of - LexResult LexState{ warnings = ws } result -> (ws, result) - where - initialState = LexState - -- TODO: add 'startPosition' - { curPos = Position 1 1 - , curInput = input - , curCode = 0 - , warnings = [] -#ifdef CABAL_PARSEC_DEBUG - , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input -#endif - } - -{-# INLINE returnLex #-} -returnLex :: a -> Lex a -returnLex a = Lex $ \s -> LexResult s a - -{-# INLINE thenLex #-} -thenLex :: Lex a -> (a -> Lex b) -> Lex b -(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s' - -setPos :: Position -> Lex () -setPos pos = Lex $ \s -> LexResult s{ curPos = pos } () - -getPos :: Lex Position -getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos - -adjustPos :: (Position -> Position) -> Lex () -adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } () - -getInput :: Lex InputStream -getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i - -setInput :: InputStream -> Lex () -setInput i = Lex $ \s -> LexResult s{ curInput = i } () - -getStartCode :: Lex Int -getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c - -setStartCode :: Int -> Lex () -setStartCode c = Lex $ \s -> LexResult s{ curCode = c } () - --- | Add warning at the current position -addWarning :: LexWarningType -> Lex () -addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } -> - LexResult s{ warnings = LexWarning wt pos : ws } () diff --git a/src/Distribution/Fields/ParseResult.hs b/src/Distribution/Fields/ParseResult.hs deleted file mode 100644 --- a/src/Distribution/Fields/ParseResult.hs +++ /dev/null @@ -1,196 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} --- | A parse result type for parsers from AST to Haskell types. -module Distribution.Fields.ParseResult ( - ParseResult, - runParseResult, - recoverWith, - parseWarning, - parseWarnings, - parseFailure, - parseFatalFailure, - parseFatalFailure', - getCabalSpecVersion, - setCabalSpecVersion, - readAndParseFile, - parseString, - withoutWarnings, - ) where - -import qualified Data.ByteString.Char8 as BS -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Distribution.Simple.Utils (die', warn) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version) -import Prelude () -import System.Directory (doesFileExist) - -#if MIN_VERSION_base(4,10,0) -import Control.Applicative (Applicative (..)) -#endif - --- | A monad with failure and accumulating errors and warnings. -newtype ParseResult a = PR - { unPR - :: forall r. PRState - -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration - -> (PRState -> a -> r) -- success - -> r - } - --- Note: we have version here, as we could get any version. -data PRState = PRState ![PWarning] ![PError] !(Maybe Version) - -emptyPRState :: PRState -emptyPRState = PRState [] [] Nothing - --- | Forget 'ParseResult's warnings. --- --- @since 3.4.0.0 -withoutWarnings :: ParseResult a -> ParseResult a -withoutWarnings m = PR $ \s failure success -> - unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s) - where - withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v - --- | Destruct a 'ParseResult' into the emitted warnings and either --- a successful value or --- list of errors and possibly recovered a spec-version declaration. -runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a) -runParseResult pr = unPR pr emptyPRState failure success - where - failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| [])) - failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where - success (PRState warns [] _) x = (warns, Right x) - -- If there are any errors, don't return the result - success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs)) - -instance Functor ParseResult where - fmap f (PR pr) = PR $ \ !s failure success -> - pr s failure $ \ !s' a -> - success s' (f a) - {-# INLINE fmap #-} - -instance Applicative ParseResult where - pure x = PR $ \ !s _ success -> success s x - {-# INLINE pure #-} - - f <*> x = PR $ \ !s0 failure success -> - unPR f s0 failure $ \ !s1 f' -> - unPR x s1 failure $ \ !s2 x' -> - success s2 (f' x') - {-# INLINE (<*>) #-} - - x *> y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 _ -> - unPR y s1 failure success - {-# INLINE (*>) #-} - - x <* y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 _ -> - success s2 x' - {-# INLINE (<*) #-} - -#if MIN_VERSION_base(4,10,0) - liftA2 f x y = PR $ \ !s0 failure success -> - unPR x s0 failure $ \ !s1 x' -> - unPR y s1 failure $ \ !s2 y' -> - success s2 (f x' y') - {-# INLINE liftA2 #-} -#endif - -instance Monad ParseResult where - return = pure - (>>) = (*>) - - m >>= k = PR $ \ !s failure success -> - unPR m s failure $ \ !s' a -> - unPR (k a) s' failure success - {-# INLINE (>>=) #-} - --- | "Recover" the parse result, so we can proceed parsing. --- 'runParseResult' will still result in 'Nothing', if there are recorded errors. -recoverWith :: ParseResult a -> a -> ParseResult a -recoverWith (PR pr) x = PR $ \ !s _failure success -> - pr s (\ !s' -> success s' x) success - --- | Set cabal spec version. -setCabalSpecVersion :: Maybe Version -> ParseResult () -setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success -> - success (PRState warns errs v) () - --- | Get cabal spec version. -getCabalSpecVersion :: ParseResult (Maybe Version) -getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success -> - success s v - --- | Add a warning. This doesn't fail the parsing process. -parseWarning :: Position -> PWarnType -> String -> ParseResult () -parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState (PWarning t pos msg : warns) errs v) () - --- | Add multiple warnings at once. -parseWarnings :: [PWarning] -> ParseResult () -parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success -> - success (PRState (newWarns ++ warns) errs v) () - --- | Add an error, but not fail the parser yet. --- --- For fatal failure use 'parseFatalFailure' -parseFailure :: Position -> String -> ParseResult () -parseFailure pos msg = PR $ \(PRState warns errs v) _failure success -> - success (PRState warns (PError pos msg : errs) v) () - --- | Add an fatal error. -parseFatalFailure :: Position -> String -> ParseResult a -parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success -> - failure (PRState warns (PError pos msg : errs) v) - --- | A 'mzero'. -parseFatalFailure' :: ParseResult a -parseFatalFailure' = PR pr - where - pr (PRState warns [] v) failure _success = failure (PRState warns [err] v) - pr s failure _success = failure s - - err = PError zeroPos "Unknown fatal error" - --- | Helper combinator to do parsing plumbing for files. --- --- Given a parser and a filename, return the parse of the file, --- after checking if the file exists. --- --- Argument order is chosen to encourage partial application. -readAndParseFile - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> FilePath -- ^ File to read - -> IO a -readAndParseFile parser verbosity fpath = do - exists <- doesFileExist fpath - unless exists $ - die' verbosity $ - "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue." - bs <- BS.readFile fpath - parseString parser verbosity fpath bs - -parseString - :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser - -> Verbosity -- ^ Verbosity level - -> String -- ^ File name - -> BS.ByteString - -> IO a -parseString parser verbosity name bs = do - let (warnings, result) = runParseResult (parser bs) - traverse_ (warn verbosity . showPWarning name) warnings - case result of - Right x -> return x - Left (_, errors) -> do - traverse_ (warn verbosity . showPError name) errors - die' verbosity $ "Failed parsing \"" ++ name ++ "\"." diff --git a/src/Distribution/Fields/Parser.hs b/src/Distribution/Fields/Parser.hs deleted file mode 100644 --- a/src/Distribution/Fields/Parser.hs +++ /dev/null @@ -1,377 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Fields.Parser --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable -module Distribution.Fields.Parser ( - -- * Types - Field(..), - Name(..), - FieldLine(..), - SectionArg(..), - -- * Grammar and parsing - -- $grammar - readFields, - readFields', -#ifdef CABAL_PARSEC_DEBUG - -- * Internal - parseFile, - parseStr, - parseBS, -#endif - ) where - -import qualified Data.ByteString.Char8 as B8 -import Data.Functor.Identity -import Distribution.Compat.Prelude -import Distribution.Fields.Field -import Distribution.Fields.Lexer -import Distribution.Fields.LexerMonad - (LexResult (..), LexState (..), LexWarning (..), unLex) -import Distribution.Parsec.Position (Position (..)) -import Prelude () -import Text.Parsec.Combinator hiding (eof, notFollowedBy) -import Text.Parsec.Error -import Text.Parsec.Pos -import Text.Parsec.Prim hiding (many, (<|>)) - -#ifdef CABAL_PARSEC_DEBUG -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -#endif - --- | The 'LexState'' (with a prime) is an instance of parsec's 'Stream' --- wrapped around lexer's 'LexState' (without a prime) -data LexState' = LexState' !LexState (LToken, LexState') - -mkLexState' :: LexState -> LexState' -mkLexState' st = LexState' st - (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st')) - -type Parser a = ParsecT LexState' () Identity a - -instance Stream LexState' Identity LToken where - uncons (LexState' _ (tok, st')) = - case tok of - L _ EOF -> return Nothing - _ -> return (Just (tok, st')) - --- | Get lexer warnings accumulated so far -getLexerWarnings :: Parser [LexWarning] -getLexerWarnings = do - LexState' (LexState { warnings = ws }) _ <- getInput - return ws - --- | Set Alex code i.e. the mode "state" lexer is in. -setLexerMode :: Int -> Parser () -setLexerMode code = do - LexState' ls _ <- getInput - setInput $! mkLexState' ls { curCode = code } - -getToken :: (Token -> Maybe a) -> Parser a -getToken getTok = getTokenWithPos (\(L _ t) -> getTok t) - -getTokenWithPos :: (LToken -> Maybe a) -> Parser a -getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTok - where - updatePos :: SourcePos -> LToken -> LexState' -> SourcePos - updatePos pos (L (Position col line) _) _ = newPos (sourceName pos) col line - -describeToken :: Token -> String -describeToken t = case t of - TokSym s -> "symbol " ++ show s - TokStr s -> "string " ++ show s - TokOther s -> "operator " ++ show s - Indent _ -> "new line" - TokFieldLine _ -> "field content" - Colon -> "\":\"" - OpenBrace -> "\"{\"" - CloseBrace -> "\"}\"" --- SemiColon -> "\";\"" - EOF -> "end of file" - LexicalError is -> "character in input " ++ show (B8.head is) - -tokSym :: Parser (Name Position) -tokSym', tokStr, tokOther :: Parser (SectionArg Position) -tokIndent :: Parser Int -tokColon, tokOpenBrace, tokCloseBrace :: Parser () -tokFieldLine :: Parser (FieldLine Position) - -tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing -tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing -tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing -tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing -tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing -tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing -tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing -tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing -tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing - -colon, openBrace, closeBrace :: Parser () - -sectionArg :: Parser (SectionArg Position) -sectionArg = tokSym' <|> tokStr <|> tokOther "section parameter" - -fieldSecName :: Parser (Name Position) -fieldSecName = tokSym "field or section name" - -colon = tokColon "\":\"" -openBrace = tokOpenBrace "\"{\"" -closeBrace = tokCloseBrace "\"}\"" - -fieldContent :: Parser (FieldLine Position) -fieldContent = tokFieldLine "field contents" - -newtype IndentLevel = IndentLevel Int - -zeroIndentLevel :: IndentLevel -zeroIndentLevel = IndentLevel 0 - -incIndentLevel :: IndentLevel -> IndentLevel -incIndentLevel (IndentLevel i) = IndentLevel (succ i) - -indentOfAtLeast :: IndentLevel -> Parser IndentLevel -indentOfAtLeast (IndentLevel i) = try $ do - j <- tokIndent - guard (j >= i) "indentation of at least " ++ show i - return (IndentLevel j) - - -newtype LexerMode = LexerMode Int - -inLexerMode :: LexerMode -> Parser p -> Parser p -inLexerMode (LexerMode mode) p = - do setLexerMode mode; x <- p; setLexerMode in_section; return x - - ------------------------ --- Cabal file grammar --- - --- $grammar --- --- @ --- CabalStyleFile ::= SecElems --- --- SecElems ::= SecElem* '\\n'? --- SecElem ::= '\\n' SecElemLayout | SecElemBraces --- SecElemLayout ::= FieldLayout | FieldBraces | SectionLayout | SectionBraces --- SecElemBraces ::= FieldInline | FieldBraces | SectionBraces --- FieldLayout ::= name ':' line? ('\\n' line)* --- FieldBraces ::= name ':' '\\n'? '{' content '}' --- FieldInline ::= name ':' content --- SectionLayout ::= name arg* SecElems --- SectionBraces ::= name arg* '\\n'? '{' SecElems '}' --- @ --- --- and the same thing but left factored... --- --- @ --- SecElems ::= SecElem* --- SecElem ::= '\\n' name SecElemLayout --- | name SecElemBraces --- SecElemLayout ::= ':' FieldLayoutOrBraces --- | arg* SectionLayoutOrBraces --- FieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* --- SectionLayoutOrBraces ::= '\\n'? '{' SecElems '\\n'? '}' --- | SecElems --- SecElemBraces ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' SecElems '\\n'? '}' --- FieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content --- @ --- --- Note how we have several productions with the sequence: --- --- > '\\n'? '{' --- --- That is, an optional newline (and indent) followed by a @{@ token. --- In the @SectionLayoutOrBraces@ case you can see that this makes it --- not fully left factored (because @SecElems@ can start with a @\\n@). --- Fully left factoring here would be ugly, and though we could use a --- lookahead of two tokens to resolve the alternatives, we can't --- conveniently use Parsec's 'try' here to get a lookahead of only two. --- So instead we deal with this case in the lexer by making a line --- where the first non-space is @{@ lex as just the @{@ token, without --- the usual indent token. Then in the parser we can resolve everything --- with just one token of lookahead and so without using 'try'. - --- Top level of a file using cabal syntax --- -cabalStyleFile :: Parser [Field Position] -cabalStyleFile = do es <- elements zeroIndentLevel - eof - return es - --- Elements that live at the top level or inside a section, ie fields --- and sectionscontent --- --- elements ::= element* -elements :: IndentLevel -> Parser [Field Position] -elements ilevel = many (element ilevel) - --- An individual element, ie a field or a section. These can either use --- layout style or braces style. For layout style then it must start on --- a line on its own (so that we know its indentation level). --- --- element ::= '\\n' name elementInLayoutContext --- | name elementInNonLayoutContext -element :: IndentLevel -> Parser (Field Position) -element ilevel = - (do ilevel' <- indentOfAtLeast ilevel - name <- fieldSecName - elementInLayoutContext (incIndentLevel ilevel') name) - <|> (do name <- fieldSecName - elementInNonLayoutContext name) - --- An element (field or section) that is valid in a layout context. --- In a layout context we can have fields and sections that themselves --- either use layout style or that use braces style. --- --- elementInLayoutContext ::= ':' fieldLayoutOrBraces --- | arg* sectionLayoutOrBraces -elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position) -elementInLayoutContext ilevel name = - (do colon; fieldLayoutOrBraces ilevel name) - <|> (do args <- many sectionArg - elems <- sectionLayoutOrBraces ilevel - return (Section name args elems)) - --- An element (field or section) that is valid in a non-layout context. --- In a non-layout context we can have only have fields and sections that --- themselves use braces style, or inline style fields. --- --- elementInNonLayoutContext ::= ':' FieldInlineOrBraces --- | arg* '\\n'? '{' elements '\\n'? '}' -elementInNonLayoutContext :: Name Position -> Parser (Field Position) -elementInNonLayoutContext name = - (do colon; fieldInlineOrBraces name) - <|> (do args <- many sectionArg - openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return (Section name args elems)) - --- The body of a field, using either layout style or braces style. --- --- fieldLayoutOrBraces ::= '\\n'? '{' content '}' --- | line? ('\\n' line)* -fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position) -fieldLayoutOrBraces ilevel name = braces <|> fieldLayout - where - braces = do - openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls) - fieldLayout = inLexerMode (LexerMode in_field_layout) $ do - l <- optionMaybe fieldContent - ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent) - return $ case l of - Nothing -> Field name ls - Just l' -> Field name (l' : ls) - --- The body of a section, using either layout style or braces style. --- --- sectionLayoutOrBraces ::= '\\n'? '{' elements \\n? '}' --- | elements -sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position] -sectionLayoutOrBraces ilevel = - (do openBrace - elems <- elements zeroIndentLevel - optional tokIndent - closeBrace - return elems) - <|> (elements ilevel) - --- The body of a field, using either inline style or braces. --- --- fieldInlineOrBraces ::= '\\n'? '{' content '}' --- | content -fieldInlineOrBraces :: Name Position -> Parser (Field Position) -fieldInlineOrBraces name = - (do openBrace - ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent) - closeBrace - return (Field name ls)) - <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent)) - return (Field name ls)) - - --- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST. -readFields :: B8.ByteString -> Either ParseError [Field Position] -readFields s = fmap fst (readFields' s) - --- | Like 'readFields' but also return lexer warnings -readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning]) -readFields' s = do - parse parser "the input" lexSt - where - parser = do - fields <- cabalStyleFile - ws <- getLexerWarnings - pure (fields, ws) - - lexSt = mkLexState' (mkLexState s) - -#ifdef CABAL_PARSEC_DEBUG -parseTest' :: Show a => Parsec LexState' () a -> SourceName -> B8.ByteString -> IO () -parseTest' p fname s = - case parse p fname (lexSt s) of - Left err -> putStrLn (formatError s err) - - Right x -> print x - where - lexSt = mkLexState' . mkLexState - -parseFile :: Show a => Parser a -> FilePath -> IO () -parseFile p f = B8.readFile f >>= \s -> parseTest' p f s - -parseStr :: Show a => Parser a -> String -> IO () -parseStr p = parseBS p . B8.pack - -parseBS :: Show a => Parser a -> B8.ByteString -> IO () -parseBS p = parseTest' p "" - -formatError :: B8.ByteString -> ParseError -> String -formatError input perr = - unlines - [ "Parse error "++ show (errorPos perr) ++ ":" - , errLine - , indicator ++ errmsg ] - where - pos = errorPos perr - ls = lines' (T.decodeUtf8With T.lenientDecode input) - errLine = T.unpack (ls !! (sourceLine pos - 1)) - indicator = replicate (sourceColumn pos) ' ' ++ "^" - errmsg = showErrorMessages "or" "unknown parse error" - "expecting" "unexpected" "end of file" - (errorMessages perr) - --- | Handles windows/osx/unix line breaks uniformly -lines' :: T.Text -> [T.Text] -lines' s1 - | T.null s1 = [] - | otherwise = case T.break (\c -> c == '\r' || c == '\n') s1 of - (l, s2) | Just (c,s3) <- T.uncons s2 - -> case T.uncons s3 of - Just ('\n', s4) | c == '\r' -> l : lines' s4 - _ -> l : lines' s3 - | otherwise -> [l] -#endif - -eof :: Parser () -eof = notFollowedBy anyToken "end of file" - where - notFollowedBy :: Parser LToken -> Parser () - notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t)) - <|> return ()) diff --git a/src/Distribution/Fields/Pretty.hs b/src/Distribution/Fields/Pretty.hs deleted file mode 100644 --- a/src/Distribution/Fields/Pretty.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} --- | Cabal-like file AST types: 'Field', 'Section' etc, --- --- This (intermediate) data type is used for pretty-printing. --- --- @since 3.0.0.0 --- -module Distribution.Fields.Pretty ( - -- * Fields - PrettyField (..), - showFields, - showFields', - -- * Transformation from 'P.Field' - fromParsecFields, - genericFromParsecFields, - prettyFieldLines, - prettySectionArgs, - ) where - -import Distribution.Compat.Prelude -import Distribution.Pretty (showToken) -import Prelude () - -import Distribution.Fields.Field (FieldName) -import Distribution.Simple.Utils (fromUTF8BS) - -import qualified Distribution.Fields.Parser as P - -import qualified Data.ByteString as BS -import qualified Text.PrettyPrint as PP - -data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] - deriving (Functor, Foldable, Traversable) - --- | Prettyprint a list of fields. --- --- Note: the first argument should return 'String's without newlines --- and properly prefixes (with @--@) to count as comments. --- This unsafety is left in place so one could generate empty lines --- between comment lines. --- -showFields :: (ann -> [String]) -> [PrettyField ann] -> String -showFields rann = showFields' rann (const id) 4 - --- | 'showFields' with user specified indentation. -showFields' - :: (ann -> [String]) - -- ^ Convert an annotation to lined to preceed the field or section. - -> (ann -> [String] -> [String]) - -- ^ Post-process non-annotation produced lines. - -> Int - -- ^ Indentation level. - -> [PrettyField ann] - -- ^ Fields/sections to show. - -> String -showFields' rann post n = unlines . renderFields (Opts rann indent post) - where - -- few hardcoded, "unrolled" variants. - indent | n == 4 = indent4 - | n == 2 = indent2 - | otherwise = (replicate (max n 1) ' ' ++) - - indent4 :: String -> String - indent4 [] = [] - indent4 xs = ' ' : ' ' : ' ' : ' ' : xs - - indent2 :: String -> String - indent2 [] = [] - indent2 xs = ' ' : ' ' : xs - -data Opts ann = Opts - { _optAnnotation ::(ann -> [String]) - , _optIndent ::(String -> String) - , _optPostprocess :: ann -> [String] -> [String] - } - -renderFields :: Opts ann -> [PrettyField ann] -> [String] -renderFields opts fields = flattenBlocks $ map (renderField opts len) fields - where - len = maxNameLength 0 fields - - maxNameLength !acc [] = acc - maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest - maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest - --- | Block of lines, --- Boolean parameter tells whether block should be surrounded by empty lines -data Block = Block Margin Margin [String] - -data Margin = Margin | NoMargin - deriving Eq - --- | Collapse margins, any margin = margin -instance Semigroup Margin where - NoMargin <> NoMargin = NoMargin - _ <> _ = Margin - -flattenBlocks :: [Block] -> [String] -flattenBlocks = go0 where - go0 [] = [] - go0 (Block _before after strs : blocks) = strs ++ go after blocks - - go _surr' [] = [] - go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where - ins | surr' <> before == Margin = ("" :) - | otherwise = id - -renderField :: Opts ann -> Int -> PrettyField ann -> Block -renderField (Opts rann indent post) fw (PrettyField ann name doc) = - Block before after $ comments ++ post ann lines' - where - comments = rann ann - before = if null comments then NoMargin else Margin - - (lines', after) = case lines narrow of - [] -> ([ name' ++ ":" ], NoMargin) - [singleLine] | length singleLine < 60 - -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin) - _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin) - - name' = fromUTF8BS name - narrow = PP.renderStyle narrowStyle doc - - narrowStyle :: PP.Style - narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } - -renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $ - rann ann - ++ - post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ] - ++ - (map indent $ renderFields opts fields) - -------------------------------------------------------------------------------- --- Transform from Parsec.Field -------------------------------------------------------------------------------- - -genericFromParsecFields - :: Applicative f - => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents - -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments - -> [P.Field ann] - -> f [PrettyField ann] -genericFromParsecFields f g = goMany where - goMany = traverse go - - go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls - go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs - --- | Used in 'fromParsecFields'. -prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc -prettyFieldLines _ fls = PP.vcat - [ PP.text $ fromUTF8BS bs - | P.FieldLine _ bs <- fls - ] - --- | Used in 'fromParsecFields'. -prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] -prettySectionArgs _ = map $ \sa -> case sa of - P.SecArgName _ bs -> showToken $ fromUTF8BS bs - P.SecArgStr _ bs -> showToken $ fromUTF8BS bs - P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs - --- | Simple variant of 'genericFromParsecField' -fromParsecFields :: [P.Field ann] -> [PrettyField ann] -fromParsecFields = runIdentity . genericFromParsecFields - (Identity .: prettyFieldLines) - (Identity .: prettySectionArgs) - where - (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) - (f .: g) x y = f (g x y) diff --git a/src/Distribution/GetOpt.hs b/src/Distribution/GetOpt.hs --- a/src/Distribution/GetOpt.hs +++ b/src/Distribution/GetOpt.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.GetOpt -- Copyright : (c) Sven Panne 2002-2005 @@ -17,54 +21,87 @@ -- * Line wrapping in the 'usageInfo' output, plus a more compact -- rendering of short options, and slightly less padding. -- --- If you want to take on the challenge of merging this with the GetOpt --- from the base package then go for it! +-- * Parsing of option arguments is allowed to fail. -- -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NamedFieldPuns #-} -module Distribution.GetOpt ( - -- * GetOpt - getOpt, getOpt', - usageInfo, - ArgOrder(..), - OptDescr(..), - ArgDescr(..), +-- * 'ReturnInOrder' argument order is removed. +module Distribution.GetOpt + ( -- * GetOpt + getOpt + , getOpt' + , usageInfo + , ArgOrder (..) + , OptDescr (..) + , ArgDescr (..) - -- * Example - -- | See "System.Console.GetOpt" for examples -) where + -- * Example -import Prelude () + -- | See "System.Console.GetOpt" for examples + ) where + import Distribution.Compat.Prelude -import System.Console.GetOpt - ( ArgOrder(..), OptDescr(..), ArgDescr(..) ) +import Prelude () -data OptKind a -- kind of cmd line arg (internal use only): - = Opt a -- an option - | UnreqOpt String -- an un-recognized option - | NonOpt String -- a non-option - | EndOfOpts -- end-of-options marker (i.e. "--") - | OptErr String -- something went wrong... +-- | What to do with options following non-options +data ArgOrder a + = -- | no option processing after first non-option + RequireOrder + | -- | freely intersperse options and non-options + Permute -data OptHelp a = OptHelp { - optNames :: a, - optHelp :: String - } +data OptDescr a -- description of a single options: + = Option + [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user +instance Functor OptDescr where + fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c + +-- | Describes whether an option takes an argument or not, and if so +-- how the argument is parsed to a value of type @a@. +-- +-- Compared to System.Console.GetOpt, we allow for parse errors. +data ArgDescr a + = -- | no argument expected + NoArg a + | -- | option requires argument + ReqArg (String -> Either String a) String + | -- | optional argument + OptArg String (Maybe String -> Either String a) String + +instance Functor ArgDescr where + fmap f (NoArg a) = NoArg (f a) + fmap f (ReqArg g s) = ReqArg (fmap f . g) s + fmap f (OptArg dv g s) = OptArg dv (fmap f . g) s + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +data OptHelp = OptHelp + { optNames :: String + , optHelp :: String + } + -- | Return a string describing the usage of a command, derived from -- the header (first argument) and the options described by the -- second argument. -usageInfo :: String -- header - -> [OptDescr a] -- option descriptors - -> String -- nicely formatted decription of options +usageInfo + :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted description of options usageInfo header optDescr = unlines (header : table) where options = flip map optDescr $ \(Option sos los ad d) -> OptHelp { optNames = - intercalate ", " $ - map (fmtShort ad) sos ++ - map (fmtLong ad) (take 1 los) + intercalate ", " $ + map (fmtShort ad) sos + ++ map (fmtLong ad) (take 1 los) , optHelp = d } @@ -76,8 +113,9 @@ OptHelp{optNames, optHelp} <- options let wrappedHelp = wrapText descolWidth optHelp if length optNames >= maxOptNameWidth - then [" " ++ optNames] ++ - renderColumns [] wrappedHelp + then + [" " ++ optNames] + ++ renderColumns [] wrappedHelp else renderColumns [optNames] wrappedHelp renderColumns :: [String] -> [String] -> [String] @@ -85,141 +123,179 @@ (x, y) <- zipDefault "" "" xs ys return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y - padTo n x = take n (x ++ repeat ' ') + padTo n x = take n (x ++ repeat ' ') -zipDefault :: a -> b -> [a] -> [b] -> [(a,b)] -zipDefault _ _ [] [] = [] -zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as -zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs -zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs +zipDefault :: a -> b -> [a] -> [b] -> [(a, b)] +zipDefault _ _ [] [] = [] +zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as +zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs +zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs +-- | Pretty printing of short options. +-- * With required arguments can be given as: +-- @-w PATH or -wPATH (but not -w=PATH)@ +-- This is displayed as: +-- @-w PATH or -wPATH@ +-- * With optional but default arguments can be given as: +-- @-j or -jNUM (but not -j=NUM or -j NUM)@ +-- This is displayed as: +-- @-j[NUM]@ fmtShort :: ArgDescr a -> Char -> String -fmtShort (NoArg _ ) so = "-" ++ [so] -fmtShort (ReqArg _ _) so = "-" ++ [so] -fmtShort (OptArg _ _) so = "-" ++ [so] - -- unlike upstream GetOpt we omit the arg name for short options +fmtShort (NoArg _) so = "-" ++ [so] +fmtShort (ReqArg _ ad) so = + let opt = "-" ++ [so] + in opt ++ " " ++ ad ++ " or " ++ opt ++ ad +fmtShort (OptArg _ _ ad) so = + let opt = "-" ++ [so] + in opt ++ "[" ++ ad ++ "]" +-- | Pretty printing of long options. +-- * With required arguments can be given as: +-- @--with-compiler=PATH (but not --with-compiler PATH)@ +-- This is displayed as: +-- @--with-compiler=PATH@ +-- * With optional but default arguments can be given as: +-- @--jobs or --jobs=NUM (but not --jobs NUM)@ +-- This is displayed as: +-- @--jobs[=NUM]@ fmtLong :: ArgDescr a -> String -> String -fmtLong (NoArg _ ) lo = "--" ++ lo -fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad -fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" +fmtLong (NoArg _) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = + let opt = "--" ++ lo + in opt ++ "=" ++ ad +fmtLong (OptArg _ _ ad) lo = + let opt = "--" ++ lo + in opt ++ "[=" ++ ad ++ "]" wrapText :: Int -> String -> [String] wrapText width = map unwords . wrap 0 [] . words - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - -{-| -Process the command-line, and return the list of values that matched -(and those that didn\'t). The arguments are: - -* The order requirements (see 'ArgOrder') - -* The option descriptions (see 'OptDescr') - -* The actual command line arguments (presumably got from - 'System.Environment.getArgs'). + where + wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w : ws) + | length w + 1 > width = + wrap (length w) [w] ws + wrap col line (w : ws) + | col + length w + 1 > width = + reverse line : wrap 0 [] (w : ws) + wrap col line (w : ws) = + let col' = col + length w + 1 + in wrap col' (w : line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] -'getOpt' returns a triple consisting of the option arguments, a list -of non-options, and a list of error messages. --} -getOpt :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String],[String]) -- (options,non-options,error messages) -getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) - where (os,xs,us,es) = getOpt' ordering optDescr args +-- | +-- Process the command-line, and return the list of values that matched +-- (and those that didn\'t). The arguments are: +-- +-- * The order requirements (see 'ArgOrder') +-- +-- * The option descriptions (see 'OptDescr') +-- +-- * The actual command line arguments (presumably got from +-- 'System.Environment.getArgs'). +-- +-- 'getOpt' returns a triple consisting of the option arguments, a list +-- of non-options, and a list of error messages. +getOpt + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us) + where + (os, xs, us, es) = getOpt' ordering optDescr args -{-| -This is almost the same as 'getOpt', but returns a quadruple -consisting of the option arguments, a list of non-options, a list of -unrecognized options, and a list of error messages. --} -getOpt' :: ArgOrder a -- non-option handling - -> [OptDescr a] -- option descriptors - -> [String] -- the command-line arguments - -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) -getOpt' _ _ [] = ([],[],[],[]) -getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering - where procNextOpt (Opt o) _ = (o:os,xs,us,es) - procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) - procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) - procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) - procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) - procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) - procNextOpt EndOfOpts Permute = ([],rest,[],[]) - procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) - procNextOpt (OptErr e) _ = (os,xs,us,e:es) +-- | +-- This is almost the same as 'getOpt', but returns a quadruple +-- consisting of the option arguments, a list of non-options, a list of +-- unrecognized options, and a list of error messages. +getOpt' + :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([], [], [], []) +getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering + where + procNextOpt (Opt o) _ = (o : os, xs, us, es) + procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es) + procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], []) + procNextOpt (NonOpt x) Permute = (os, x : xs, us, es) + procNextOpt EndOfOpts RequireOrder = ([], rest, [], []) + procNextOpt EndOfOpts Permute = ([], rest, [], []) + procNextOpt (OptErr e) _ = (os, xs, us, e : es) - (opt,rest) = getNext arg args optDescr - (os,xs,us,es) = getOpt' ordering optDescr rest + (opt, rest) = getNext arg args optDescr + (os, xs, us, es) = getOpt' ordering optDescr rest -- take a look at the next cmd line arg and decide what to do with it -getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) -getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) -getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr -getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr -getNext a rest _ = (NonOpt a,rest) +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) +getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest) +getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr +getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a, rest) -- handle long option -longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String]) longOpt ls rs optDescr = long ads arg rs - where (opt,arg) = break (=='=') ls - getWith p = [ o | o@(Option _ xs _ _) <- optDescr - , isJust (find (p opt) xs)] - exact = getWith (==) - options = if null exact then getWith isPrefixOf else exact - ads = [ ad | Option _ _ ad _ <- options ] - optStr = "--" ++ opt + where + (opt, arg) = break (== '=') ls + getWith p = + [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs) + ] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ad | Option _ _ ad _ <- options] + optStr = "--" ++ opt + fromRes = fromParseResult optStr - long (_:_:_) _ rest = (errAmbig options optStr,rest) - long [NoArg a ] [] rest = (Opt a,rest) - long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) - long [ReqArg _ d] [] [] = (errReq d optStr,[]) - long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) - long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) - long [OptArg f _] [] rest = (Opt (f Nothing),rest) - long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) - long _ _ rest = (UnreqOpt ("--"++ls),rest) + long (_ : _ : _) _ rest = (errAmbig options optStr, rest) + long [NoArg a] [] rest = (Opt a, rest) + long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest) + long [ReqArg _ d] [] [] = (errReq d optStr, []) + long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest) + long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest) + long [OptArg _ f _] [] rest = (fromRes (f Nothing), rest) + long [OptArg _ f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest) + long _ _ rest = (UnreqOpt ("--" ++ ls), rest) -- handle short option -shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String]) shortOpt y ys rs optDescr = short ads ys rs - where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] - ads = [ ad | Option _ _ ad _ <- options ] - optStr = '-':[y] + where + options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s] + ads = [ad | Option _ _ ad _ <- options] + optStr = '-' : [y] + fromRes = fromParseResult optStr - short (_:_:_) _ rest = (errAmbig options optStr,rest) - short (NoArg a :_) [] rest = (Opt a,rest) - short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) - short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) - short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) - short (ReqArg f _:_) xs rest = (Opt (f xs),rest) - short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) - short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) - short [] [] rest = (UnreqOpt optStr,rest) - short [] xs rest = (UnreqOpt (optStr++xs),rest) - -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) - -- Apparently this was part of the change so that flags that are - -- not recognised as global flags are passed on to the sub-command. - -- But why was no equivalent change required for longOpt? So could - -- this change go upstream? + short (_ : _ : _) _ rest = (errAmbig options optStr, rest) + short (NoArg a : _) [] rest = (Opt a, rest) + short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest) + short (ReqArg _ d : _) [] [] = (errReq d optStr, []) + short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest) + short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest) + short (OptArg _ f _ : _) [] rest = (fromRes (f Nothing), rest) + short (OptArg _ f _ : _) xs rest = (fromRes (f (Just xs)), rest) + short [] [] rest = (UnreqOpt optStr, rest) + short [] xs rest = (UnreqOpt (optStr ++ xs), rest) +-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest) +-- Apparently this was part of the change so that flags that are +-- not recognised as global flags are passed on to the sub-command. +-- But why was no equivalent change required for longOpt? So could +-- this change go upstream? + +fromParseResult :: String -> Either String a -> OptKind a +fromParseResult optStr res = case res of + Right x -> Opt x + Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n") + -- miscellaneous error formatting -errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig :: [OptDescr a] -> String -> OptKind b errAmbig ods optStr = OptErr (usageInfo header ods) - where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + where + header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" errReq :: String -> String -> OptKind a errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") diff --git a/src/Distribution/InstalledPackageInfo.hs b/src/Distribution/InstalledPackageInfo.hs deleted file mode 100644 --- a/src/Distribution/InstalledPackageInfo.hs +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.InstalledPackageInfo --- Copyright : (c) The University of Glasgow 2004 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- This is the information about an /installed/ package that --- is communicated to the @ghc-pkg@ program in order to register --- a package. @ghc-pkg@ now consumes this package format (as of version --- 6.4). This is specific to GHC at the moment. --- --- The @.cabal@ file format is for describing a package that is not yet --- installed. It has a lot of flexibility, like conditionals and dependency --- ranges. As such, that format is not at all suitable for describing a package --- that has already been built and installed. By the time we get to that stage, --- we have resolved all conditionals and resolved dependency version --- constraints to exact versions of dependent packages. So, this module defines --- the 'InstalledPackageInfo' data structure that contains all the info we keep --- about an installed package. There is a parser and pretty printer. The --- textual format is rather simpler than the @.cabal@ format: there are no --- sections, for example. - --- This module is meant to be local-only to Distribution... - -module Distribution.InstalledPackageInfo ( - InstalledPackageInfo(..), - installedComponentId, - installedOpenUnitId, - sourceComponentName, - requiredSignatures, - ExposedModule(..), - AbiDependency(..), - emptyInstalledPackageInfo, - parseInstalledPackageInfo, - showInstalledPackageInfo, - showFullInstalledPackageInfo, - showInstalledPackageInfoField, - showSimpleInstalledPackageInfoField, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion (cabalSpecLatest) -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.ComponentName -import Distribution.Utils.Generic (toUTF8BS) - -import Data.ByteString (ByteString) - -import qualified Data.Map as Map -import qualified Distribution.Fields as P -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo -import Distribution.Types.InstalledPackageInfo.FieldGrammar - --- $setup --- >>> :set -XOverloadedStrings - -installedComponentId :: InstalledPackageInfo -> ComponentId -installedComponentId ipi = - case unComponentId (installedComponentId_ ipi) of - "" -> mkComponentId (unUnitId (installedUnitId ipi)) - _ -> installedComponentId_ ipi - --- | Get the indefinite unit identity representing this package. --- This IS NOT guaranteed to give you a substitution; for --- instantiated packages you will get @DefiniteUnitId (installedUnitId ipi)@. --- For indefinite libraries, however, you will correctly get --- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'. -installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId -installedOpenUnitId ipi - = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi)) - --- | Returns the set of module names which need to be filled for --- an indefinite package, or the empty set if the package is definite. -requiredSignatures :: InstalledPackageInfo -> Set ModuleName -requiredSignatures ipi = openModuleSubstFreeHoles (Map.fromList (instantiatedWith ipi)) - --- ----------------------------------------------------------------------------- --- Munging - -sourceComponentName :: InstalledPackageInfo -> ComponentName -sourceComponentName = CLibName . sourceLibName - --- ----------------------------------------------------------------------------- --- Parsing - --- | Return either errors, or IPI with list of warnings -parseInstalledPackageInfo - :: ByteString - -> Either (NonEmpty String) ([String], InstalledPackageInfo) -parseInstalledPackageInfo s = case P.readFields s of - Left err -> Left (show err :| []) - Right fs -> case partitionFields fs of - (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of - (ws, Right x) -> x `deepseq` Right (ws', x) where - ws' = [ P.showPWarning "" w - | w@(P.PWarning wt _ _) <- ws - -- filter out warnings about experimental features - , wt /= P.PWTExperimental - ] - (_, Left (_, errs)) -> Left errs' where - errs' = fmap (P.showPError "") errs - --- ----------------------------------------------------------------------------- --- Pretty-printing - --- | Pretty print 'InstalledPackageInfo'. --- --- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4). -showInstalledPackageInfo :: InstalledPackageInfo -> String -showInstalledPackageInfo ipi = - showFullInstalledPackageInfo ipi { pkgRoot = Nothing } - --- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. -showFullInstalledPackageInfo :: InstalledPackageInfo -> String -showFullInstalledPackageInfo = P.showFields (const []) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar - --- | --- --- >>> let ipi = emptyInstalledPackageInfo { maintainer = "Tester" } --- >>> fmap ($ ipi) $ showInstalledPackageInfoField "maintainer" --- Just "maintainer: Tester" -showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showInstalledPackageInfoField fn = - fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - -showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) -showSimpleInstalledPackageInfoField fn = - fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn) - where - myStyle = Disp.style { Disp.mode = Disp.LeftMode } - -ppField :: String -> Disp.Doc -> Disp.Doc -ppField name fielddoc - | Disp.isEmpty fielddoc = mempty - | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc diff --git a/src/Distribution/Lex.hs b/src/Distribution/Lex.hs --- a/src/Distribution/Lex.hs +++ b/src/Distribution/Lex.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Lex -- Copyright : Ben Gamari 2015-2019 @@ -7,34 +8,43 @@ -- Portability : portable -- -- This module contains a simple lexer supporting quoted strings - -module Distribution.Lex ( - tokenizeQuotedWords - ) where +module Distribution.Lex + ( tokenizeQuotedWords + ) where -import Prelude () -import Distribution.Compat.Prelude import Distribution.Compat.DList +import Distribution.Compat.Prelude +import Prelude () +-- | A simple parser supporting quoted strings. +-- +-- Please be aware that this will only split strings when seeing whitespace +-- outside of quotation marks, i.e, @"foo\"bar baz\"qux quux"@ will be +-- converted to @["foobar bazqux", "quux"]@. +-- +-- This behavior can be useful when parsing text like +-- @"ghc-options: -Wl,\"some option with spaces\""@, for instance. tokenizeQuotedWords :: String -> [String] tokenizeQuotedWords = filter (not . null) . go False mempty where - go :: Bool -- ^ in quoted region - -> DList Char -- ^ accumulator - -> String -- ^ string to be parsed - -> [String] -- ^ parse result + go + :: Bool + -- \^ in quoted region + -> DList Char + -- \^ accumulator + -> String + -- \^ string to be parsed + -> [String] + -- \^ parse result go _ accum [] | [] <- accum' = [] - | otherwise = [accum'] - where accum' = runDList accum - - go False accum (c:cs) + | otherwise = [accum'] + where + accum' = runDList accum + go False accum (c : cs) | isSpace c = runDList accum : go False mempty cs - | c == '"' = go True accum cs - - go True accum (c:cs) - | c == '"' = go False accum cs - - go quoted accum (c:cs) - = go quoted (accum `mappend` singleton c) cs - + | c == '"' = go True accum cs + go True accum (c : cs) + | c == '"' = go False accum cs + go quoted accum (c : cs) = + go quoted (accum `mappend` singleton c) cs diff --git a/src/Distribution/License.hs b/src/Distribution/License.hs deleted file mode 100644 --- a/src/Distribution/License.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.License --- Description : The License data type. --- Copyright : Isaac Jones 2003-2005 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Package descriptions contain fields for specifying the name of a software --- license and the name of the file containing the text of that license. While --- package authors may choose any license they like, Cabal provides an --- enumeration of a small set of common free and open source software licenses. --- This is done so that Hackage can recognise licenses, so that tools can detect --- , --- and to deter --- . --- --- 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 --- . --- --- = Additional resources --- --- The following websites provide information about free and open source --- software licenses: --- --- * --- --- * --- --- = Disclaimer --- --- The descriptions of software licenses provided by this documentation are --- intended for informational purposes only and in no way constitute legal --- advice. Please read the text of the licenses and consult a lawyer for any --- advice regarding software licensing. - -module Distribution.License ( - License(..), - knownLicenses, - licenseToSPDX, - licenseFromSPDX, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Data.Map.Strict as Map -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - --- | Indicates the license under which a package's source code is released. --- Versions of the licenses not listed here will be rejected by Hackage and --- cause @cabal check@ to issue a warning. -data License = - -- TODO: * remove BSD4 - - -- | GNU General Public License, - -- or - -- . - GPL (Maybe Version) - - -- | . - | AGPL (Maybe Version) - - -- | GNU Lesser General Public License, - -- or - -- . - | LGPL (Maybe Version) - - -- | . - | BSD2 - - -- | . - | BSD3 - - -- | . - -- 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 - - -- | . - | MIT - - -- | - | ISC - - -- | . - | MPL Version - - -- | . - | Apache (Maybe Version) - - -- | The author of a package disclaims any copyright to its source code and - -- dedicates it to the public domain. This is not a software license. Please - -- note that it is not possible to dedicate works to the public domain in - -- every jurisdiction, nor is a work that is in the public domain in one - -- jurisdiction necessarily in the public domain elsewhere. - | PublicDomain - - -- | Explicitly 'All Rights Reserved', eg for proprietary software. The - -- package may not be legally modified or redistributed by anyone but the - -- rightsholder. - | AllRightsReserved - - -- | No license specified which legally defaults to 'All Rights Reserved'. - -- The package may not be legally modified or redistributed by anyone but - -- the rightsholder. - | UnspecifiedLicense - - -- | Any other software license. - | OtherLicense - - -- | Indicates an erroneous license name. - | UnknownLicense String - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary License -instance Structured License -instance NFData License where rnf = genericRnf - --- | The list of all currently recognised licenses. -knownLicenses :: [License] -knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) - , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3]) - , AGPL unversioned, AGPL (version [3]) - , BSD2, BSD3, MIT, ISC - , MPL (mkVersion [2, 0]) - , Apache unversioned, Apache (version [2, 0]) - , PublicDomain, AllRightsReserved, OtherLicense] - where - unversioned = Nothing - version = Just . mkVersion - --- | Convert old 'License' to SPDX 'SPDX.License'. --- Non-SPDX licenses are converted to 'SPDX.LicenseRef'. --- --- @since 2.2.0.0 -licenseToSPDX :: License -> SPDX.License -licenseToSPDX l = case l of - GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only - GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only - LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only - LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only - AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only - BSD2 -> spdx SPDX.BSD_2_Clause - BSD3 -> spdx SPDX.BSD_3_Clause - BSD4 -> spdx SPDX.BSD_4_Clause - MIT -> spdx SPDX.MIT - ISC -> spdx SPDX.ISC - MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0 - Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0 - AllRightsReserved -> SPDX.NONE - UnspecifiedLicense -> SPDX.NONE - OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense") - PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain") - UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str) - _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l) - where - version = Just . mkVersion - spdx = SPDX.License . SPDX.simpleLicenseExpression - ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing - --- | Convert 'SPDX.License' to 'License', --- --- This is lossy conversion. We try our best. --- --- >>> licenseFromSPDX . licenseToSPDX $ BSD3 --- BSD3 --- --- >>> licenseFromSPDX . licenseToSPDX $ GPL (Just (mkVersion [3])) --- GPL (Just (mkVersion [3])) --- --- >>> licenseFromSPDX . licenseToSPDX $ PublicDomain --- UnknownLicense "LicenseRefPublicDomain" --- --- >>> licenseFromSPDX $ SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1 --- UnknownLicense "EUPL-1.1" --- --- >>> licenseFromSPDX . licenseToSPDX $ AllRightsReserved --- AllRightsReserved --- --- >>> licenseFromSPDX <$> simpleParsec "BSD-3-Clause OR GPL-3.0-only" --- Just (UnknownLicense "BSD3ClauseORGPL30only") --- --- @since 2.2.0.0 -licenseFromSPDX :: SPDX.License -> License -licenseFromSPDX SPDX.NONE = AllRightsReserved -licenseFromSPDX l = - fromMaybe (mungle $ prettyShow l) $ Map.lookup l m - where - m :: Map.Map SPDX.License License - m = Map.fromList $ filter (isSimple . fst ) $ - map (\x -> (licenseToSPDX x, x)) knownLicenses - - isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True - isSimple _ = False - - mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name) - - mangle c - | isAlphaNum c = Just c - | otherwise = Nothing - -instance Pretty License where - pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version - pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version - pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version - pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version - pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version - pretty (UnknownLicense other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec License where - parsec = do - name <- P.munch1 isAlphaNum - version <- P.optional (P.char '-' *> parsec) - return $! case (name, version :: Maybe Version) of - ("GPL", _ ) -> GPL version - ("LGPL", _ ) -> LGPL version - ("AGPL", _ ) -> AGPL version - ("BSD2", Nothing) -> BSD2 - ("BSD3", Nothing) -> BSD3 - ("BSD4", Nothing) -> BSD4 - ("ISC", Nothing) -> ISC - ("MIT", Nothing) -> MIT - ("MPL", Just version') -> MPL version' - ("Apache", _ ) -> Apache version - ("PublicDomain", Nothing) -> PublicDomain - ("AllRightsReserved", Nothing) -> AllRightsReserved - ("OtherLicense", Nothing) -> OtherLicense - _ -> UnknownLicense $ name ++ - maybe "" (('-':) . prettyShow) version - -dispOptVersion :: Maybe Version -> Disp.Doc -dispOptVersion Nothing = Disp.empty -dispOptVersion (Just v) = dispVersion v - -dispVersion :: Version -> Disp.Doc -dispVersion v = Disp.char '-' <<>> pretty v diff --git a/src/Distribution/Make.hs b/src/Distribution/Make.hs --- a/src/Distribution/Make.hs +++ b/src/Distribution/Make.hs @@ -2,6 +2,11 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + -- | -- Module : Distribution.Make -- Copyright : Martin Sjögren 2004 @@ -51,32 +56,26 @@ -- [UnregisterCmd] We assume there is an @unregister@ target. -- -- [HaddockCmd] We assume there is a @docs@ or @doc@ target. - - --- copy : --- $(MAKE) install prefix=$(destdir)/$(prefix) \ --- bindir=$(destdir)/$(bindir) \ - -module Distribution.Make ( - module Distribution.Package, - License(..), Version, - defaultMain, defaultMainArgs +module Distribution.Make + ( module Distribution.Package + , License (..) + , Version + , defaultMain + , defaultMainArgs ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -- local +import Distribution.License import Distribution.Package +import Distribution.Pretty +import Distribution.Simple.Command import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.Command - import Distribution.Simple.Utils - -import Distribution.License import Distribution.Version -import Distribution.Pretty import System.Environment (getArgs, getProgName) @@ -87,20 +86,21 @@ defaultMainArgs = defaultMainHelper defaultMainHelper :: [String] -> IO () -defaultMainHelper args = - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> +defaultMainHelper args = do + command <- commandsRun (globalCommand commands) commands args + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion + _ + | fromFlag (globalVersion flags) -> printVersion | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action where printHelp help = getProgName >>= putStr . help printOptionsList = putStr . unlines @@ -108,75 +108,94 @@ putStr (intercalate "\n" errs) exitWith (ExitFailure 1) printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion - + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion progs = defaultProgramDb commands = - [configureCommand progs `commandAddAction` configureAction - ,buildCommand progs `commandAddAction` buildAction - ,installCommand `commandAddAction` installAction - ,copyCommand `commandAddAction` copyAction - ,haddockCommand `commandAddAction` haddockAction - ,cleanCommand `commandAddAction` cleanAction - ,sdistCommand `commandAddAction` sdistAction - ,registerCommand `commandAddAction` registerAction - ,unregisterCommand `commandAddAction` unregisterAction + [ configureCommand progs `commandAddAction` configureAction + , buildCommand progs `commandAddAction` buildAction + , installCommand `commandAddAction` installAction + , copyCommand `commandAddAction` copyAction + , haddockCommand `commandAddAction` haddockAction + , cleanCommand `commandAddAction` cleanAction + , sdistCommand `commandAddAction` sdistAction + , registerCommand `commandAddAction` registerAction + , unregisterCommand `commandAddAction` unregisterAction ] configureAction :: ConfigFlags -> [String] -> IO () configureAction flags args = do noExtraFlags args - let verbosity = fromFlag (configVerbosity flags) - rawSystemExit verbosity "sh" $ + let verbosity = fromFlag $ configVerbosity flags + mbWorkDir = flagToMaybe $ configWorkingDir flags + rawSystemExit verbosity mbWorkDir "sh" $ "configure" - : configureArgs backwardsCompatHack flags - where backwardsCompatHack = True + : configureArgs backwardsCompatHack flags + where + backwardsCompatHack = True copyAction :: CopyFlags -> [String] -> IO () copyAction flags args = do noExtraFlags args - let destArgs = case fromFlag $ copyDest flags of - NoCopyDest -> ["install"] - CopyTo path -> ["copy", "destdir=" ++ path] - CopyToDb _ -> error "CopyToDb not supported via Make" + let verbosity = fromFlag $ copyVerbosity flags + mbWorkDir = flagToMaybe $ copyWorkingDir flags + destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + CopyToDb _ -> error "CopyToDb not supported via Make" - rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + rawSystemExit verbosity mbWorkDir "make" destArgs installAction :: InstallFlags -> [String] -> IO () installAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] - rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + let verbosity = fromFlag $ installVerbosity flags + mbWorkDir = flagToMaybe $ installWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["install"] + rawSystemExit verbosity mbWorkDir "make" ["register"] haddockAction :: HaddockFlags -> [String] -> IO () haddockAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["docs"] `catchIO` \_ -> - rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + rawSystemExit verbosity mbWorkDir "make" ["doc"] buildAction :: BuildFlags -> [String] -> IO () buildAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + let verbosity = fromFlag $ buildVerbosity flags + mbWorkDir = flagToMaybe $ buildWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" [] cleanAction :: CleanFlags -> [String] -> IO () cleanAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + let verbosity = fromFlag $ cleanVerbosity flags + mbWorkDir = flagToMaybe $ cleanWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["clean"] sdistAction :: SDistFlags -> [String] -> IO () sdistAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + let verbosity = fromFlag $ sDistVerbosity flags + mbWorkDir = flagToMaybe $ sDistWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["dist"] registerAction :: RegisterFlags -> [String] -> IO () -registerAction flags args = do +registerAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + let verbosity = fromFlag $ registerVerbosity flags + mbWorkDir = flagToMaybe $ registerWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["register"] unregisterAction :: RegisterFlags -> [String] -> IO () unregisterAction flags args = do noExtraFlags args - rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] + let verbosity = fromFlag $ registerVerbosity flags + mbWorkDir = flagToMaybe $ registerWorkingDir flags + rawSystemExit verbosity mbWorkDir "make" ["unregister"] diff --git a/src/Distribution/ModuleName.hs b/src/Distribution/ModuleName.hs deleted file mode 100644 --- a/src/Distribution/ModuleName.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.ModuleName --- Copyright : Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Data type for Haskell module names. - -module Distribution.ModuleName ( - ModuleName, - fromString, - fromComponents, - components, - toFilePath, - main, - -- * Internal - validModuleComponent, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) -import System.FilePath (pathSeparator) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - --- | A valid Haskell module name. --- -newtype ModuleName = ModuleName ShortText - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -unModuleName :: ModuleName -> String -unModuleName (ModuleName s) = fromShortText s - -instance Binary ModuleName -instance Structured ModuleName - -instance NFData ModuleName where - rnf (ModuleName ms) = rnf ms - -instance Pretty ModuleName where - pretty = Disp.text . unModuleName - -instance Parsec ModuleName where - parsec = parsecModuleName - -parsecModuleName :: forall m. CabalParsing m => m ModuleName -parsecModuleName = state0 DList.empty where - upper :: m Char - !upper = P.satisfy isUpper - - ch :: m Char - !ch = P.satisfy (\c -> validModuleChar c || c == '.') - - alt :: m ModuleName -> m ModuleName -> m ModuleName - !alt = (<|>) - - state0 :: DList.DList Char -> m ModuleName - state0 acc = do - c <- upper - state1 (DList.snoc acc c) - - state1 :: DList.DList Char -> m ModuleName - state1 acc = state1' acc `alt` return (fromString (DList.toList acc)) - - state1' :: DList.DList Char -> m ModuleName - state1' acc = do - c <- ch - case c of - '.' -> state0 (DList.snoc acc c) - _ -> state1 (DList.snoc acc c) - -validModuleChar :: Char -> Bool -validModuleChar c = isAlphaNum c || c == '_' || c == '\'' - -validModuleComponent :: String -> Bool -validModuleComponent [] = False -validModuleComponent (c:cs) = isUpper c && all validModuleChar cs - --- | Construct a 'ModuleName' from a valid module name 'String'. --- --- This is just a convenience function intended for valid module strings. It is --- an error if it is used with a string that is not a valid module name. If you --- are parsing user input then use 'Distribution.Text.simpleParse' instead. --- -instance IsString ModuleName where - fromString = ModuleName . toShortText - --- | Construct a 'ModuleName' from valid module components, i.e. parts --- separated by dots. -fromComponents :: [String] -> ModuleName -fromComponents comps = fromString (intercalate "." comps) -{-# DEPRECATED fromComponents "Exists for cabal-install only" #-} - --- | The module name @Main@. --- -main :: ModuleName -main = ModuleName (fromString "Main") - --- | The individual components of a hierarchical module name. For example --- --- > components (fromString "A.B.C") = ["A", "B", "C"] --- -components :: ModuleName -> [String] -components mn = split (unModuleName mn) - where - split cs = case break (=='.') cs of - (chunk,[]) -> chunk : [] - (chunk,_:rest) -> chunk : split rest - --- | Convert a module name to a file path, but without any file extension. --- For example: --- --- > toFilePath (fromString "A.B.C") = "A/B/C" --- -toFilePath :: ModuleName -> FilePath -toFilePath = map f . unModuleName where - f '.' = pathSeparator - f c = c diff --git a/src/Distribution/Package.hs b/src/Distribution/Package.hs deleted file mode 100644 --- a/src/Distribution/Package.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Package --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Defines a package identifier along with a parser and pretty printer for it. --- 'PackageIdentifier's consist of a name and an exact version. It also defines --- a 'Dependency' data type. A dependency is a package name and a version --- range, like @\"foo >= 1.2 && < 2\"@. - -module Distribution.Package - ( module Distribution.Types.AbiHash - , module Distribution.Types.ComponentId - , module Distribution.Types.PackageId - , module Distribution.Types.UnitId - , module Distribution.Types.Module - , module Distribution.Types.PackageName - , module Distribution.Types.PkgconfigName - , module Distribution.Types.Dependency - , Package(..), packageName, packageVersion - , HasMungedPackageId(..), mungedName', mungedVersion' - , HasUnitId(..) - , PackageInstalled(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Version - ( Version ) - -import Distribution.Types.AbiHash -import Distribution.Types.ComponentId -import Distribution.Types.Dependency -import Distribution.Types.MungedPackageId -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.Module -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigName - --- | Class of things that have a 'PackageIdentifier' --- --- Types in this class are all notions of a package. This allows us to have --- different types for the different phases that packages go though, from --- simple name\/id, package description, configured or installed packages. --- --- Not all kinds of packages can be uniquely identified by a --- 'PackageIdentifier'. In particular, installed packages cannot, there may be --- many installed instances of the same source package. --- -class Package pkg where - packageId :: pkg -> PackageIdentifier - -mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName -mungedName' = mungedName . mungedId - -mungedVersion' :: HasMungedPackageId munged => munged -> Version -mungedVersion' = mungedVersion . mungedId - -class HasMungedPackageId pkg where - mungedId :: pkg -> MungedPackageId - -instance Package PackageIdentifier where - packageId = id - -packageName :: Package pkg => pkg -> PackageName -packageName = pkgName . packageId - -packageVersion :: Package pkg => pkg -> Version -packageVersion = pkgVersion . packageId - -instance HasMungedPackageId MungedPackageId where - mungedId = id - --- | Packages that have an installed unit ID -class Package pkg => HasUnitId pkg where - installedUnitId :: pkg -> UnitId - --- | Class of installed packages. --- --- The primary data type which is an instance of this package is --- 'InstalledPackageInfo', but when we are doing install plans in Cabal install --- we may have other, installed package-like things which contain more metadata. --- Installed packages have exact dependencies 'installedDepends'. -class (HasUnitId pkg) => PackageInstalled pkg where - installedDepends :: pkg -> [UnitId] diff --git a/src/Distribution/PackageDescription.hs b/src/Distribution/PackageDescription.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription.hs +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Backwards compatibility reexport of most things you need to know --- about @.cabal@ files. - -module Distribution.PackageDescription ( - -- * PD and GPD - module Distribution.Types.PackageDescription, - module Distribution.Types.GenericPackageDescription, - -- * Components - module Distribution.Types.ComponentName, - -- ** Library - module Distribution.Types.Library, - module Distribution.Types.LibraryName, - module Distribution.Types.LibraryVisibility, - -- ** Executable - module Distribution.Types.Executable, - module Distribution.Types.ExecutableScope, - -- ** TestSuite - module Distribution.Types.TestSuite, - module Distribution.Types.TestType, - module Distribution.Types.TestSuiteInterface, - -- ** Benchmark - module Distribution.Types.Benchmark, - module Distribution.Types.BenchmarkType, - module Distribution.Types.BenchmarkInterface, - -- ** Foreign library - module Distribution.Types.ForeignLib, - module Distribution.Types.ForeignLibType, - module Distribution.Types.ForeignLibOption, - -- * BuildInfo - module Distribution.Types.BuildType, - module Distribution.Types.BuildInfo, - module Distribution.Types.HookedBuildInfo, - module Distribution.Types.SetupBuildInfo, - -- * Flags - module Distribution.Types.Flag, - -- * Identifiers - module Distribution.Types.PackageId, - module Distribution.Types.PackageName, - module Distribution.Types.UnqualComponentName, - -- * Pkgconfig - module Distribution.Types.PkgconfigName, - module Distribution.Types.PkgconfigVersion, - module Distribution.Types.PkgconfigVersionRange, - -- * Dependencies - module Distribution.Types.Dependency, - module Distribution.Types.ExeDependency, - module Distribution.Types.LegacyExeDependency, - module Distribution.Types.PkgconfigDependency, - -- * Condition trees - module Distribution.Types.CondTree, - module Distribution.Types.Condition, - module Distribution.Types.ConfVar, - -- * Mixin - module Distribution.Types.IncludeRenaming, - module Distribution.Types.Mixin, - module Distribution.Types.ModuleReexport, - module Distribution.Types.ModuleRenaming, - -- * Source repository - module Distribution.Types.SourceRepo, - ) where - -import Prelude () ---import Distribution.Compat.Prelude - -import Distribution.Types.Benchmark -import Distribution.Types.BenchmarkInterface -import Distribution.Types.BenchmarkType -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.ComponentName -import Distribution.Types.Condition -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.ExecutableScope -import Distribution.Types.ExeDependency -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.GenericPackageDescription -import Distribution.Types.HookedBuildInfo -import Distribution.Types.IncludeRenaming -import Distribution.Types.LegacyExeDependency -import Distribution.Types.Library -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.Mixin -import Distribution.Types.ModuleReexport -import Distribution.Types.ModuleRenaming -import Distribution.Types.PackageDescription -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.PkgconfigDependency -import Distribution.Types.PkgconfigName -import Distribution.Types.PkgconfigVersion -import Distribution.Types.PkgconfigVersionRange -import Distribution.Types.SetupBuildInfo -import Distribution.Types.SourceRepo -import Distribution.Types.TestSuite -import Distribution.Types.TestSuiteInterface -import Distribution.Types.TestType -import Distribution.Types.UnqualComponentName diff --git a/src/Distribution/PackageDescription/Check.hs b/src/Distribution/PackageDescription/Check.hs --- a/src/Distribution/PackageDescription/Check.hs +++ b/src/Distribution/PackageDescription/Check.hs @@ -1,2392 +1,1111 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Check --- Copyright : Lennart Kolmodin 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This has code for checking for various problems in packages. There is one --- set of checks that just looks at a 'PackageDescription' in isolation and --- another set of checks that also looks at files in the package. Some of the --- checks are basic sanity checks, others are portability standards that we'd --- like to encourage. There is a 'PackageCheck' type that distinguishes the --- different kinds of checks so we can see which ones are appropriate to report --- in different situations. This code gets used when configuring a package when --- we consider only basic problems. The higher standard is used when --- preparing a source tarball and by Hackage when uploading new packages. The --- reason for this is that we want to hold packages that are expected to be --- distributed to a higher standard than packages that are only ever expected --- to be used on the author's own environment. - -module Distribution.PackageDescription.Check ( - -- * Package Checking - PackageCheck(..), - checkPackage, - checkConfiguredPackage, - - -- ** Checking package contents - checkPackageFiles, - checkPackageContent, - CheckPackageContentOps(..), - checkPackageFileNames, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Data.List (group) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Pretty (prettyShow) -import Distribution.Simple.BuildPaths (autogenPathsModuleName) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.CCompiler -import Distribution.Simple.Glob -import Distribution.Simple.Utils hiding (findPackageDesc, notice) -import Distribution.System -import Distribution.Types.ComponentRequestedSpec -import Distribution.Utils.Generic (isAscii) -import Distribution.Verbosity -import Distribution.Version -import Distribution.Utils.Path -import Language.Haskell.Extension -import System.FilePath - (splitDirectories, splitExtension, splitPath, takeExtension, takeFileName, (<.>), ()) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.Map as Map -import qualified Distribution.Compat.DList as DList -import qualified Distribution.SPDX as SPDX -import qualified System.Directory as System - -import qualified System.Directory (getDirectoryContents) -import qualified System.FilePath.Windows as FilePath.Windows (isValid) - -import qualified Data.Set as Set -import qualified Distribution.Utils.ShortText as ShortText - -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L - --- $setup --- >>> import Control.Arrow ((&&&)) - --- | Results of some kind of failed package check. --- --- There are a range of severities, from merely dubious to totally insane. --- All of them come with a human readable explanation. In future we may augment --- them with more machine readable explanations, for example to help an IDE --- suggest automatic corrections. --- -data PackageCheck = - - -- | This package description is no good. There's no way it's going to - -- build sensibly. This should give an error at configure time. - PackageBuildImpossible { explanation :: String } - - -- | A problem that is likely to affect building the package, or an - -- issue that we'd like every package author to be aware of, even if - -- the package is never distributed. - | PackageBuildWarning { explanation :: String } - - -- | An issue that might not be a problem for the package author but - -- might be annoying or detrimental when the package is distributed to - -- users. We should encourage distributed packages to be free from these - -- issues, but occasionally there are justifiable reasons so we cannot - -- ban them entirely. - | PackageDistSuspicious { explanation :: String } - - -- | Like PackageDistSuspicious but will only display warnings - -- rather than causing abnormal exit when you run 'cabal check'. - | PackageDistSuspiciousWarn { explanation :: String } - - -- | An issue that is OK in the author's environment but is almost - -- certain to be a portability problem for other environments. We can - -- quite legitimately refuse to publicly distribute packages with these - -- problems. - | PackageDistInexcusable { explanation :: String } - deriving (Eq, Ord) - -instance Show PackageCheck where - show notice = explanation notice - -check :: Bool -> PackageCheck -> Maybe PackageCheck -check False _ = Nothing -check True pc = Just pc - -checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck - -> Maybe PackageCheck -checkSpecVersion pkg specver cond pc - | specVersion pkg >= specver = Nothing - | otherwise = check cond pc - --- ------------------------------------------------------------ --- * Standard checks --- ------------------------------------------------------------ - --- | Check for common mistakes and problems in package descriptions. --- --- This is the standard collection of checks covering all aspects except --- for checks that require looking at files within the package. For those --- see 'checkPackageFiles'. --- --- It requires the 'GenericPackageDescription' and optionally a particular --- configuration of that package. If you pass 'Nothing' then we just check --- a version of the generic description using 'flattenPackageDescription'. --- -checkPackage :: GenericPackageDescription - -> Maybe PackageDescription - -> [PackageCheck] -checkPackage gpkg mpkg = - checkConfiguredPackage pkg - ++ checkConditionals gpkg - ++ checkPackageVersions gpkg - ++ checkDevelopmentOnlyFlags gpkg - ++ checkFlagNames gpkg - ++ checkUnusedFlags gpkg - ++ checkUnicodeXFields gpkg - ++ checkPathsModuleExtensions pkg - where - pkg = fromMaybe (flattenPackageDescription gpkg) mpkg - ---TODO: make this variant go away --- we should always know the GenericPackageDescription -checkConfiguredPackage :: PackageDescription -> [PackageCheck] -checkConfiguredPackage pkg = - checkSanity pkg - ++ checkFields pkg - ++ checkLicense pkg - ++ checkSourceRepos pkg - ++ checkAllGhcOptions pkg - ++ checkCCOptions pkg - ++ checkCxxOptions pkg - ++ checkCPPOptions pkg - ++ checkPaths pkg - ++ checkCabalVersion pkg - - --- ------------------------------------------------------------ --- * Basic sanity checks --- ------------------------------------------------------------ - --- | Check that this package description is sane. --- -checkSanity :: PackageDescription -> [PackageCheck] -checkSanity pkg = - catMaybes [ - - check (null . unPackageName . packageName $ pkg) $ - PackageBuildImpossible "No 'name' field." - - , check (nullVersion == packageVersion pkg) $ - PackageBuildImpossible "No 'version' field." - - , check (all ($ pkg) [ null . executables - , null . testSuites - , null . benchmarks - , null . allLibraries - , null . foreignLibs ]) $ - PackageBuildImpossible - "No executables, libraries, tests, or benchmarks found. Nothing to do." - - , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $ - PackageBuildImpossible $ "Found one or more unnamed internal libraries. " - ++ "Only the non-internal library can have the same name as the package." - - , check (not (null duplicateNames)) $ - PackageBuildImpossible $ "Duplicate sections: " - ++ commaSep (map unUnqualComponentName duplicateNames) - ++ ". The name of every library, executable, test suite," - ++ " and benchmark section in" - ++ " the package must be unique." - - -- NB: but it's OK for executables to have the same name! - -- TODO shouldn't need to compare on the string level - , check (any (== prettyShow (packageName pkg)) (prettyShow <$> subLibNames)) $ - PackageBuildImpossible $ "Illegal internal library name " - ++ prettyShow (packageName pkg) - ++ ". Internal libraries cannot have the same name as the package." - ++ " Maybe you wanted a non-internal library?" - ++ " If so, rewrite the section stanza" - ++ " from 'library: '" ++ prettyShow (packageName pkg) ++ "' to 'library'." - ] - --TODO: check for name clashes case insensitively: windows file systems cannot - --cope. - - ++ concatMap (checkLibrary pkg) (allLibraries pkg) - ++ concatMap (checkExecutable pkg) (executables pkg) - ++ concatMap (checkTestSuite pkg) (testSuites pkg) - ++ concatMap (checkBenchmark pkg) (benchmarks pkg) - - where - -- The public 'library' gets special dispensation, because it - -- is common practice to export a library and name the executable - -- the same as the package. - subLibNames = mapMaybe (libraryNameString . libName) $ subLibraries pkg - exeNames = map exeName $ executables pkg - testNames = map testName $ testSuites pkg - bmNames = map benchmarkName $ benchmarks pkg - duplicateNames = dups $ subLibNames ++ exeNames ++ testNames ++ bmNames - -checkLibrary :: PackageDescription -> Library -> [PackageCheck] -checkLibrary pkg lib = - catMaybes [ - - check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in library: " - ++ commaSep (map prettyShow moduleDuplicates) - - -- TODO: This check is bogus if a required-signature was passed through - , check (null (explicitLibModules lib) && null (reexportedModules lib)) $ - PackageDistSuspiciousWarn $ - showLibraryName (libName lib) ++ " does not expose any modules" - - -- check use of signatures sections - , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $ - PackageDistInexcusable $ - "To use the 'signatures' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." - - -- check that all autogen-modules appear on other-modules or exposed-modules - , check - (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $ - PackageBuildImpossible $ - "An 'autogen-module' is neither on 'exposed-modules' or " - ++ "'other-modules'." - - -- check that all autogen-includes appear on includes or install-includes - , check - (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $ - PackageBuildImpossible $ - "An include in 'autogen-includes' is neither in 'includes' or " - ++ "'install-includes'." - ] - - where - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - -- TODO: not sure if this check is always right in Backpack - moduleDuplicates = dups (explicitLibModules lib ++ - map moduleReexportName (reexportedModules lib)) - -allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath] -allExplicitIncludes x = view L.includes x ++ view L.installIncludes x - -checkExecutable :: PackageDescription -> Executable -> [PackageCheck] -checkExecutable pkg exe = - catMaybes [ - - check (null (modulePath exe)) $ - PackageBuildImpossible $ - "No 'main-is' field found for executable " ++ prettyShow (exeName exe) - - , check (not (null (modulePath exe)) - && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." - - , checkSpecVersion pkg CabalSpecV1_18 - (fileExtensionSupportedLanguage (modulePath exe) - && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ - PackageDistInexcusable $ - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." - - , check (not (null moduleDuplicates)) $ - PackageBuildImpossible $ - "Duplicate modules in executable '" ++ prettyShow (exeName exe) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $ - PackageBuildImpossible $ - "On executable '" ++ prettyShow (exeName exe) ++ "' an 'autogen-module' is not " - ++ "on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups (exeModules exe) - -checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] -checkTestSuite pkg test = - catMaybes [ - - case testInterface test of - TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a known type of test suite. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) - - TestSuiteUnsupported tt -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a supported test suite version. " - ++ "The known test suite types are: " - ++ commaSep (map prettyShow knownTestTypes) - _ -> Nothing - - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in test suite '" ++ prettyShow (testName test) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - , check mainIsWrongExt $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor), " - ++ "or it may specify a C/C++/obj-C source file." - - , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $ - PackageDistInexcusable $ - "The package uses a C/C++/obj-C source file for the 'main-is' field. " - ++ "To use this feature you must specify 'cabal-version: >= 1.18'." - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $ - PackageBuildImpossible $ - "On test suite '" ++ prettyShow (testName test) ++ "' an 'autogen-module' is not " - ++ "on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups $ testModules test - - mainIsWrongExt = case testInterface test of - TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f - _ -> False - - mainIsNotHsExt = case testInterface test of - TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - -checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] -checkBenchmark _pkg bm = - catMaybes [ - - case benchmarkInterface bm of - BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a known type of benchmark. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) - - BenchmarkUnsupported tt -> Just $ - PackageBuildWarning $ - quote (prettyShow tt) ++ " is not a supported benchmark version. " - ++ "The known benchmark types are: " - ++ commaSep (map prettyShow knownBenchmarkTypes) - _ -> Nothing - - , check (not $ null moduleDuplicates) $ - PackageBuildImpossible $ - "Duplicate modules in benchmark '" ++ prettyShow (benchmarkName bm) ++ "': " - ++ commaSep (map prettyShow moduleDuplicates) - - , check mainIsWrongExt $ - PackageBuildImpossible $ - "The 'main-is' field must specify a '.hs' or '.lhs' file " - ++ "(even if it is generated by a preprocessor)." - - -- check that all autogen-modules appear on other-modules - , check - (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $ - PackageBuildImpossible $ - "On benchmark '" ++ prettyShow (benchmarkName bm) ++ "' an 'autogen-module' is " - ++ "not on 'other-modules'" - - -- check that all autogen-includes appear on includes - , check - (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $ - PackageBuildImpossible "An include in 'autogen-includes' is not in 'includes'." - ] - where - moduleDuplicates = dups $ benchmarkModules bm - - mainIsWrongExt = case benchmarkInterface bm of - BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] - _ -> False - --- ------------------------------------------------------------ --- * Additional pure checks --- ------------------------------------------------------------ - -checkFields :: PackageDescription -> [PackageCheck] -checkFields pkg = - catMaybes [ - - check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $ - PackageDistInexcusable $ - "Unfortunately, the package name '" ++ prettyShow (packageName pkg) - ++ "' is one of the reserved system file names on Windows. Many tools " - ++ "need to convert package names to file names so using this name " - ++ "would cause problems." - - , check ((isPrefixOf "z-") . prettyShow . packageName $ pkg) $ - PackageDistInexcusable $ - "Package names with the prefix 'z-' are reserved by Cabal and " - ++ "cannot be used." - - , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $ - PackageBuildWarning $ - "No 'build-type' specified. If you do not need a custom Setup.hs or " - ++ "./configure script then use 'build-type: Simple'." - - , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $ - PackageBuildWarning $ - "Ignoring the 'custom-setup' section because the 'build-type' is " - ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a " - ++ "custom Setup.hs script." - - , check (not (null unknownCompilers)) $ - PackageBuildWarning $ - "Unknown compiler " ++ commaSep (map quote unknownCompilers) - ++ " in 'tested-with' field." - - , check (not (null unknownLanguages)) $ - PackageBuildWarning $ - "Unknown languages: " ++ commaSep unknownLanguages - - , check (not (null unknownExtensions)) $ - PackageBuildWarning $ - "Unknown extensions: " ++ commaSep unknownExtensions - - , check (not (null languagesUsedAsExtensions)) $ - PackageBuildWarning $ - "Languages listed as extensions: " - ++ commaSep languagesUsedAsExtensions - ++ ". Languages must be specified in either the 'default-language' " - ++ " or the 'other-languages' field." - - , check (not (null ourDeprecatedExtensions)) $ - PackageDistSuspicious $ - "Deprecated extensions: " - ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions) - ++ ". " ++ unwords - [ "Instead of '" ++ prettyShow ext - ++ "' use '" ++ prettyShow replacement ++ "'." - | (ext, Just replacement) <- ourDeprecatedExtensions ] - - , check (ShortText.null (category pkg)) $ - PackageDistSuspicious "No 'category' field." - - , check (ShortText.null (maintainer pkg)) $ - PackageDistSuspicious "No 'maintainer' field." - - , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $ - PackageDistInexcusable "No 'synopsis' or 'description' field." - - , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $ - PackageDistSuspicious "No 'description' field." - - , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $ - PackageDistSuspicious "No 'synopsis' field." - - --TODO: recommend the bug reports URL, author and homepage fields - --TODO: recommend not using the stability field - --TODO: recommend specifying a source repo - - , check (ShortText.length (synopsis pkg) >= 80) $ - PackageDistSuspicious - "The 'synopsis' field is rather long (max 80 chars is recommended)." - - -- See also https://github.com/haskell/cabal/pull/3479 - , check (not (ShortText.null (description pkg)) - && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $ - PackageDistSuspicious $ - "The 'description' field should be longer than the 'synopsis' " - ++ "field. " - ++ "It's useful to provide an informative 'description' to allow " - ++ "Haskell programmers who have never heard about your package to " - ++ "understand the purpose of your package. " - ++ "The 'description' field content is typically shown by tooling " - ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which " - ++ "serves as a headline. " - ++ "Please refer to " - ++ " for more details." - - -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" - , check (not (null testedWithImpossibleRanges)) $ - PackageDistInexcusable $ - "Invalid 'tested-with' version range: " - ++ commaSep (map prettyShow testedWithImpossibleRanges) - ++ ". To indicate that you have tested a package with multiple " - ++ "different versions of the same compiler use multiple entries, " - ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " - ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." - - -- for more details on why the following was commented out, - -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507 - -- , check (not (null depInternalLibraryWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal library: " - -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's library will always be used." - - , check (not (null depInternalLibraryWithImpossibleVersion)) $ - PackageBuildImpossible $ - "The package has an impossible version range for a dependency on an " - ++ "internal library: " - ++ commaSep (map prettyShow depInternalLibraryWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's library will always be used." - - -- , check (not (null depInternalExecutableWithExtraVersion)) $ - -- PackageBuildWarning $ - -- "The package has an extraneous version range for a dependency on an " - -- ++ "internal executable: " - -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion) - -- ++ ". This version range includes the current package but isn't needed " - -- ++ "as the current package's executable will always be used." - - , check (not (null depInternalExecutableWithImpossibleVersion)) $ - PackageBuildImpossible $ - "The package has an impossible version range for a dependency on an " - ++ "internal executable: " - ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) - ++ ". This version range does not include the current package, and must " - ++ "be removed as the current package's executable will always be used." - - , check (not (null depMissingInternalExecutable)) $ - PackageBuildImpossible $ - "The package depends on a missing internal executable: " - ++ commaSep (map prettyShow depInternalExecutableWithImpossibleVersion) - ] - where - unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] - unknownLanguages = [ name | bi <- allBuildInfo pkg - , UnknownLanguage name <- allLanguages bi ] - unknownExtensions = [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `notElem` map prettyShow knownLanguages ] - ourDeprecatedExtensions = nub $ catMaybes - [ find ((==ext) . fst) deprecatedExtensions - | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - languagesUsedAsExtensions = - [ name | bi <- allBuildInfo pkg - , UnknownExtension name <- allExtensions bi - , name `elem` map prettyShow knownLanguages ] - - testedWithImpossibleRanges = - [ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet - | (compiler, vr) <- testedWith pkg - , isNoVersion vr ] - - internalLibraries = - map (maybe (packageName pkg) (unqualComponentNameToPackageName) . libraryNameString . libName) - (allLibraries pkg) - - internalExecutables = map exeName $ executables pkg - - internalLibDeps = - [ dep - | bi <- allBuildInfo pkg - , dep@(Dependency name _ _) <- targetBuildDepends bi - , name `elem` internalLibraries - ] - - internalExeDeps = - [ dep - | bi <- allBuildInfo pkg - , dep <- getAllToolDependencies pkg bi - , isInternal pkg dep - ] - - -- depInternalLibraryWithExtraVersion = - -- [ dep - -- | dep@(Dependency _ versionRange _) <- internalLibDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalLibraryWithImpossibleVersion = - [ dep - | dep@(Dependency _ versionRange _) <- internalLibDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - -- depInternalExecutableWithExtraVersion = - -- [ dep - -- | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - -- , not $ isAnyVersion versionRange - -- , packageVersion pkg `withinRange` versionRange - -- ] - - depInternalExecutableWithImpossibleVersion = - [ dep - | dep@(ExeDependency _ _ versionRange) <- internalExeDeps - , not $ packageVersion pkg `withinRange` versionRange - ] - - depMissingInternalExecutable = - [ dep - | dep@(ExeDependency _ eName _) <- internalExeDeps - , not $ eName `elem` internalExecutables - ] - - -checkLicense :: PackageDescription -> [PackageCheck] -checkLicense pkg = case licenseRaw pkg of - Right l -> checkOldLicense pkg l - Left l -> checkNewLicense pkg l - -checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck] -checkNewLicense _pkg lic = catMaybes - [ check (lic == SPDX.NONE) $ - PackageDistInexcusable - "The 'license' field is missing or is NONE." - ] - -checkOldLicense :: PackageDescription -> License -> [PackageCheck] -checkOldLicense pkg lic = catMaybes - [ check (lic == UnspecifiedLicense) $ - PackageDistInexcusable - "The 'license' field is missing." - - , check (lic == AllRightsReserved) $ - PackageDistSuspicious - "The 'license' is AllRightsReserved. Is that really what you want?" - - , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $ - PackageDistInexcusable $ - "Unfortunately the license " ++ quote (prettyShow (license pkg)) - ++ " messes up the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then use 'OtherLicense'." - - , case lic of - UnknownLicense l -> Just $ - PackageBuildWarning $ - quote ("license: " ++ l) ++ " is not a recognised license. The " - ++ "known licenses are: " - ++ commaSep (map prettyShow knownLicenses) - _ -> Nothing - - , check (lic == BSD4) $ - PackageDistSuspicious $ - "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " - ++ "refers to the old 4-clause BSD license with the advertising " - ++ "clause. 'BSD3' refers the new 3-clause BSD license." - - , case unknownLicenseVersion (lic) of - Just knownVersions -> Just $ - PackageDistSuspicious $ - "'license: " ++ prettyShow (lic) ++ "' is not a known " - ++ "version of that license. The known versions are " - ++ commaSep (map prettyShow knownVersions) - ++ ". If this is not a mistake and you think it should be a known " - ++ "version then please file a ticket." - _ -> Nothing - - , check (lic `notElem` [ AllRightsReserved - , UnspecifiedLicense, PublicDomain] - -- AllRightsReserved and PublicDomain are not strictly - -- licenses so don't need license files. - && null (licenseFiles pkg)) $ - PackageDistSuspicious "A 'license-file' is not specified." - ] - where - unknownLicenseVersion (GPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] - unknownLicenseVersion (LGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (AGPL (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ] - unknownLicenseVersion (Apache (Just v)) - | v `notElem` knownVersions = Just knownVersions - where knownVersions = [ v' | Apache (Just v') <- knownLicenses ] - unknownLicenseVersion _ = Nothing - - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4 - , PublicDomain, AllRightsReserved - , UnspecifiedLicense, OtherLicense ] - -checkSourceRepos :: PackageDescription -> [PackageCheck] -checkSourceRepos pkg = - catMaybes $ concat [[ - - case repoKind repo of - RepoKindUnknown kind -> Just $ PackageDistInexcusable $ - quote kind ++ " is not a recognised kind of source-repository. " - ++ "The repo kind is usually 'head' or 'this'" - _ -> Nothing - - , check (isNothing (repoType repo)) $ - PackageDistInexcusable - "The source-repository 'type' is a required field." - - , check (isNothing (repoLocation repo)) $ - PackageDistInexcusable - "The source-repository 'location' is a required field." - - , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $ - PackageDistInexcusable - "For a CVS source-repository, the 'module' is a required field." - - , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $ - PackageDistInexcusable $ - "For the 'this' kind of source-repository, the 'tag' is a required " - ++ "field. It should specify the tag corresponding to this version " - ++ "or release of the package." - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable - "The 'subdir' field of a source-repository must be a relative path." - - , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $ - PackageDistInexcusable - "The 'subdir' field of a source-repository must be a relative path." - - , do - subdir <- repoSubdir repo - err <- isGoodRelativeDirectoryPath subdir - return $ PackageDistInexcusable $ - "The 'subdir' field of a source-repository is not a good relative path: " ++ show err - ] - | repo <- sourceRepos pkg ] - ---TODO: check location looks like a URL for some repo types. - --- | Checks GHC options from all ghc-*-options fields in the given --- PackageDescription and reports commonly misused or non-portable flags -checkAllGhcOptions :: PackageDescription -> [PackageCheck] -checkAllGhcOptions pkg = - checkGhcOptions "ghc-options" (hcOptions GHC) pkg - ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg - ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg - --- | Extracts GHC options belonging to the given field from the given --- PackageDescription using given function and checks them for commonly misused --- or non-portable flags -checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkGhcOptions fieldName getOptions pkg = - catMaybes [ - - checkFlags ["-fasm"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU " - ++ "architectures other than x86, x86-64, ppc or sparc." - - , checkFlags ["-fvia-C"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package " - ++ "needs -via-C for correctness rather than performance then it " - ++ "is using the FFI incorrectly and will probably not work with GHC " - ++ "6.10 or later." - - , checkFlags ["-fhpc"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag " - ++ " --enable-coverage instead." - - , checkFlags ["-prof"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems " - ++ "when used on a library. Use the configure flag " - ++ "--enable-library-profiling and/or --enable-profiling." - - , checkFlags ["-o"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -o' is not needed. " - ++ "The output files are named automatically." - - , checkFlags ["-hide-package"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -hide-package' is never needed. " - ++ "Cabal hides all packages." - - , checkFlags ["--make"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": --make' is never needed. Cabal uses this automatically." - - , checkFlags ["-main-is"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -main-is' is not portable." - - , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." - - , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $ - PackageDistSuspiciousWarn $ - "'" ++ fieldName ++ ": -O0' is not needed. " - ++ "Use the --disable-optimization configure flag." - - , checkFlags [ "-O", "-O1"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -O' is not needed. " - ++ "Cabal automatically adds the '-O' flag. " - ++ "Setting it yourself interferes with the --disable-optimization flag." - - , checkFlags ["-O2"] $ - PackageDistSuspiciousWarn $ - "'" ++ fieldName ++ ": -O2' is rarely needed. " - ++ "Check that it is giving a real benefit " - ++ "and not just imposing longer compile times on your users." - - , checkFlags ["-split-sections"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -split-sections' is not needed. " - ++ "Use the --enable-split-sections configure flag." - - , checkFlags ["-split-objs"] $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -split-objs' is not needed. " - ++ "Use the --enable-split-objs configure flag." - - , checkFlags ["-optl-Wl,-s", "-optl-s"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to all" - ++ " operating systems. Cabal 1.4 and later automatically strip" - ++ " executables. Cabal also has a flag --disable-executable-stripping" - ++ " which is necessary when building packages for some Linux" - ++ " distributions and using '-optl-Wl,-s' prevents that from working." - - , checkFlags ["-fglasgow-exts"] $ - PackageDistSuspicious $ - "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use " - ++ "the 'extensions' field." - - , check ("-threaded" `elem` lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -threaded' has no effect for libraries. It should " - ++ "only be used for executables." - - , check ("-rtsopts" `elem` lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should " - ++ "only be used for executables." - - , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $ - PackageBuildWarning $ - "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It " - ++ "should only be used for executables." - - , checkAlternatives fieldName "extensions" - [ (flag, prettyShow extension) | flag <- all_ghc_options - , Just extension <- [ghcExtension flag] ] - - , checkAlternatives fieldName "extensions" - [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] - - , checkAlternatives fieldName "cpp-options" $ - [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] - ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] - - , checkAlternatives fieldName "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] - - , checkAlternatives fieldName "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] - - , checkAlternatives fieldName "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] - - , checkAlternatives fieldName "frameworks" - [ (flag, fmwk) | (flag@"-framework", fmwk) <- - zip all_ghc_options (safeTail all_ghc_options) ] - - , checkAlternatives fieldName "extra-framework-dirs" - [ (flag, dir) | (flag@"-framework-path", dir) <- - zip all_ghc_options (safeTail all_ghc_options) ] - ] - - where - all_ghc_options = concatMap getOptions (allBuildInfo pkg) - lib_ghc_options = concatMap (getOptions . libBuildInfo) - (allLibraries pkg) - test_ghc_options = concatMap (getOptions . testBuildInfo) - (testSuites pkg) - benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo) - (benchmarks pkg) - test_and_benchmark_ghc_options = test_ghc_options ++ - benchmark_ghc_options - non_test_and_benchmark_ghc_options = concatMap getOptions - (allBuildInfo (pkg { testSuites = [] - , benchmarks = [] - })) - - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) all_ghc_options) - - checkTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkTestAndBenchmarkFlags flags = check (any (`elem` flags) test_and_benchmark_ghc_options) - - checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options) - - ghcExtension ('-':'f':name) = case name of - "allow-overlapping-instances" -> enable OverlappingInstances - "no-allow-overlapping-instances" -> disable OverlappingInstances - "th" -> enable TemplateHaskell - "no-th" -> disable TemplateHaskell - "ffi" -> enable ForeignFunctionInterface - "no-ffi" -> disable ForeignFunctionInterface - "fi" -> enable ForeignFunctionInterface - "no-fi" -> disable ForeignFunctionInterface - "monomorphism-restriction" -> enable MonomorphismRestriction - "no-monomorphism-restriction" -> disable MonomorphismRestriction - "mono-pat-binds" -> enable MonoPatBinds - "no-mono-pat-binds" -> disable MonoPatBinds - "allow-undecidable-instances" -> enable UndecidableInstances - "no-allow-undecidable-instances" -> disable UndecidableInstances - "allow-incoherent-instances" -> enable IncoherentInstances - "no-allow-incoherent-instances" -> disable IncoherentInstances - "arrows" -> enable Arrows - "no-arrows" -> disable Arrows - "generics" -> enable Generics - "no-generics" -> disable Generics - "implicit-prelude" -> enable ImplicitPrelude - "no-implicit-prelude" -> disable ImplicitPrelude - "implicit-params" -> enable ImplicitParams - "no-implicit-params" -> disable ImplicitParams - "bang-patterns" -> enable BangPatterns - "no-bang-patterns" -> disable BangPatterns - "scoped-type-variables" -> enable ScopedTypeVariables - "no-scoped-type-variables" -> disable ScopedTypeVariables - "extended-default-rules" -> enable ExtendedDefaultRules - "no-extended-default-rules" -> disable ExtendedDefaultRules - _ -> Nothing - ghcExtension "-cpp" = enable CPP - ghcExtension _ = Nothing - - enable e = Just (EnableExtension e) - disable e = Just (DisableExtension e) - -checkCCOptions :: PackageDescription -> [PackageCheck] -checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions - -checkCxxOptions :: PackageDescription -> [PackageCheck] -checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions - -checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck] -checkCLikeOptions label prefix accessor pkg = - catMaybes [ - - checkAlternatives prefix "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ] - - , checkAlternatives prefix "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ] - - , checkAlternatives "ld-options" "extra-libraries" - [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] - - , checkAlternatives "ld-options" "extra-lib-dirs" - [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] - - , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ - PackageDistSuspicious $ - "'"++prefix++": -O[n]' is generally not needed. When building with " - ++ " optimisations Cabal automatically adds '-O2' for "++label++" code. " - ++ "Setting it yourself interferes with the --disable-optimization flag." - ] - - where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg - , opts <- accessor bi ] - all_ldOptions = [ opts | bi <- allBuildInfo pkg - , opts <- ldOptions bi ] - - checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions) - -checkCPPOptions :: PackageDescription -> [PackageCheck] -checkCPPOptions pkg = catMaybes - [ checkAlternatives "cpp-options" "include-dirs" - [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ] - ] - ++ - [ PackageBuildWarning $ "'cpp-options': " ++ opt ++ " is not portable C-preprocessor flag" - | opt <- all_cppOptions - -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF - , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ] - ] - where - all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ] - -checkAlternatives :: String -> String -> [(String, String)] - -> Maybe PackageCheck -checkAlternatives badField goodField flags = - check (not (null badFlags)) $ - PackageBuildWarning $ - "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) - ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) - - where (badFlags, goodFlags) = unzip flags - -data PathKind - = PathKindFile - | PathKindDirectory - | PathKindGlob - -checkPaths :: PackageDescription -> [PackageCheck] -checkPaths pkg = - [ PackageBuildWarning $ - quote (field ++ ": " ++ path) - ++ " is a relative path outside of the source tree. " - ++ "This will not work when generating a tarball with 'sdist'." - | (path, field, _) <- relPaths ++ absPaths - , isOutsideTree path ] - ++ - [ PackageDistInexcusable $ - quote (field ++ ": " ++ path) ++ " is an absolute path." - | (path, field, _) <- relPaths - , isAbsoluteOnAnyPlatform path ] - ++ - [ PackageDistInexcusable $ - quote (field ++ ": " ++ path) ++ " is not good relative path: " ++ err - | (path, field, kind) <- relPaths - -- these are not paths, but globs... - , err <- maybeToList $ case kind of - PathKindFile -> isGoodRelativeFilePath path - PathKindGlob -> isGoodRelativeGlob path - PathKindDirectory -> isGoodRelativeDirectoryPath path - ] - ++ - [ PackageDistInexcusable $ - quote (field ++ ": " ++ path) ++ " points inside the 'dist' " - ++ "directory. This is not reliable because the location of this " - ++ "directory is configurable by the user (or package manager). In " - ++ "addition the layout of the 'dist' directory is subject to change " - ++ "in future versions of Cabal." - | (path, field, _) <- relPaths ++ absPaths - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - "The 'ghc-options' contains the path '" ++ path ++ "' which points " - ++ "inside the 'dist' directory. This is not reliable because the " - ++ "location of this directory is configurable by the user (or package " - ++ "manager). In addition the layout of the 'dist' directory is subject " - ++ "to change in future versions of Cabal." - | bi <- allBuildInfo pkg - , (GHC, flags) <- perCompilerFlavorToList $ options bi - , path <- flags - , isInsideDist path ] - ++ - [ PackageDistInexcusable $ - "In the 'data-files' field: " ++ explainGlobSyntaxError pat err - | pat <- dataFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable $ - "In the 'extra-source-files' field: " ++ explainGlobSyntaxError pat err - | pat <- extraSrcFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - ++ - [ PackageDistInexcusable $ - "In the 'extra-doc-files' field: " ++ explainGlobSyntaxError pat err - | pat <- extraDocFiles pkg - , Left err <- [parseFileGlob (specVersion pkg) pat] - ] - where - isOutsideTree path = case splitDirectories path of - "..":_ -> True - ".":"..":_ -> True - _ -> False - isInsideDist path = case map lowercase (splitDirectories path) of - "dist" :_ -> True - ".":"dist":_ -> True - _ -> False - - -- paths that must be relative - relPaths :: [(FilePath, String, PathKind)] - relPaths = - [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++ - [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++ - [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++ - [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++ - [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++ - [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++ - concat - [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++ - [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++ - [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++ - [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++ - [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++ - [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++ - [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ] - | bi <- allBuildInfo pkg - ] - - -- paths that are allowed to be absolute - absPaths :: [(FilePath, String, PathKind)] - absPaths = concat - [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++ - [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++ - [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] - | bi <- allBuildInfo pkg - ] - ---TODO: check sets of paths that would be interpreted differently between Unix --- and windows, ie case-sensitive or insensitive. Things that might clash, or --- conversely be distinguished. - ---TODO: use the tar path checks on all the above paths - --- | Check that the package declares the version in the @\"cabal-version\"@ --- field correctly. --- -checkCabalVersion :: PackageDescription -> [PackageCheck] -checkCabalVersion pkg = - catMaybes [ - - -- check use of test suite sections - checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $ - PackageDistInexcusable $ - "The 'test-suite' section is new in Cabal 1.10. " - ++ "Unfortunately it messes up the parser in older Cabal versions " - ++ "so you must specify at least 'cabal-version: >= 1.8', but note " - ++ "that only Cabal 1.10 and later can actually run such test suites." - - -- check use of default-language field - -- note that we do not need to do an equivalent check for the - -- other-language field since that one does not change behaviour - , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $ - PackageBuildWarning $ - "To use the 'default-language' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4 - && (any isNothing (buildInfoField defaultLanguage))) $ - PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' must specify the " - ++ "'default-language' field for each component (e.g. Haskell98 or " - ++ "Haskell2010). If a component uses different languages in " - ++ "different modules then list the other ones in the " - ++ "'other-languages' field." - - , checkVersion CabalSpecV1_18 - (not . null $ extraDocFiles pkg) $ - PackageDistInexcusable $ - "To use the 'extra-doc-files' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.18'." - - , checkVersion CabalSpecV2_0 - (not (null (subLibraries pkg))) $ - PackageDistInexcusable $ - "To use multiple 'library' sections or a named library section " - ++ "the package needs to specify at least 'cabal-version: 2.0'." - - -- check use of reexported-modules sections - , checkVersion CabalSpecV1_22 - (any (not.null.reexportedModules) (allLibraries pkg)) $ - PackageDistInexcusable $ - "To use the 'reexported-module' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.22'." - - -- check use of thinning and renaming - , checkVersion CabalSpecV2_0 usesBackpackIncludes $ - PackageDistInexcusable $ - "To use the 'mixins' field the package needs to specify " - ++ "at least 'cabal-version: 2.0'." - - -- check use of 'extra-framework-dirs' field - , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $ - -- Just a warning, because this won't break on old Cabal versions. - PackageDistSuspiciousWarn $ - "To use the 'extra-framework-dirs' field the package needs to specify" - ++ " at least 'cabal-version: >= 1.24'." - - -- check use of default-extensions field - -- don't need to do the equivalent check for other-extensions - , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $ - PackageBuildWarning $ - "To use the 'default-extensions' field the package needs to specify " - ++ "at least 'cabal-version: >= 1.10'." - - -- check use of extensions field - , check (specVersion pkg >= CabalSpecV1_10 - && (any (not . null) (buildInfoField oldExtensions))) $ - PackageBuildWarning $ - "For packages using 'cabal-version: >= 1.10' the 'extensions' " - ++ "field is deprecated. The new 'default-extensions' field lists " - ++ "extensions that are used in all modules in the component, while " - ++ "the 'other-extensions' field lists extensions that are used in " - ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." - - , checkVersion CabalSpecV3_0 (any (not . null) - (concatMap buildInfoField - [ asmSources - , cmmSources - , extraBundledLibs - , extraLibFlavours ])) $ - PackageDistInexcusable $ - "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' " - ++ " and 'extra-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'." - - , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $ - PackageDistInexcusable $ - "The use of 'extra-dynamic-library-flavours' requires the package " - ++ " to specify at least 'cabal-version: 3.0'. The flavours are: " - ++ commaSep [ flav - | flavs <- buildInfoField extraDynLibFlavours - , flav <- flavs ] - - , checkVersion CabalSpecV2_2 (any (not . null) - (buildInfoField virtualModules)) $ - PackageDistInexcusable $ - "The use of 'virtual-modules' requires the package " - ++ " to specify at least 'cabal-version: 2.2'." - - -- check use of "source-repository" section - , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $ - PackageDistInexcusable $ - "The 'source-repository' section is new in Cabal 1.6. " - ++ "Unfortunately it messes up the parser in earlier Cabal versions " - ++ "so you need to specify 'cabal-version: >= 1.6'." - - -- check for new language extensions - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal12)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal12) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then you may be able to " - ++ "use an equivalent compiler-specific flag." - - , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $ - PackageDistInexcusable $ - "Unfortunately the language extensions " - ++ commaSep (map (quote . prettyShow) mentionedExtensionsThatNeedCabal14) - ++ " break the parser in earlier Cabal versions so you need to " - ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " - ++ "compatibility with earlier Cabal versions then you may be able to " - ++ "use an equivalent compiler-specific flag." - - , check (specVersion pkg >= CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageBuildWarning $ - "Packages using 'cabal-version: >= 1.24' with 'build-type: Custom' " - ++ "must use a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." - - , check (specVersion pkg < CabalSpecV1_24 - && isNothing (setupBuildInfo pkg) - && buildType pkg == Custom) $ - PackageDistSuspiciousWarn $ - "From version 1.24 cabal supports specifying explicit dependencies " - ++ "for Custom setup scripts. Consider using cabal-version >= 1.24 and " - ++ "adding a 'custom-setup' section with a 'setup-depends' field " - ++ "that specifies the dependencies of the Setup.hs script itself. " - ++ "The 'setup-depends' field uses the same syntax as 'build-depends', " - ++ "so a simple example would be 'setup-depends: base, Cabal'." - - , check (specVersion pkg >= CabalSpecV2_0 - && elem (autogenPathsModuleName pkg) allModuleNames - && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $ - PackageDistInexcusable $ - "Packages using 'cabal-version: 2.0' and the autogenerated " - ++ "module Paths_* must include it also on the 'autogen-modules' field " - ++ "besides 'exposed-modules' and 'other-modules'. This specifies that " - ++ "the module does not come with the package and is generated on " - ++ "setup. Modules built with a custom Setup.hs script also go here " - ++ "to ensure that commands like sdist don't fail." - - ] - where - -- Perform a check on packages that use a version of the spec less than - -- the version given. This is for cases where a new Cabal version adds - -- a new feature and we want to check that it is not used prior to that - -- version. - checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck - checkVersion ver cond pc - | specVersion pkg >= ver = Nothing - | otherwise = check cond pc - - buildInfoField field = map field (allBuildInfo pkg) - - usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) - - mentionedExtensions = [ ext | bi <- allBuildInfo pkg - , ext <- allExtensions bi ] - mentionedExtensionsThatNeedCabal12 = - nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) - - -- As of Cabal-1.4 we can add new extensions without worrying about - -- breaking old versions of cabal. - mentionedExtensionsThatNeedCabal14 = - nub (filter (`notElem` compatExtensions) mentionedExtensions) - - -- The known extensions in Cabal-1.2.3 - compatExtensions = - map EnableExtension - [ OverlappingInstances, UndecidableInstances, IncoherentInstances - , RecursiveDo, ParallelListComp, MultiParamTypeClasses - , FunctionalDependencies, Rank2Types - , RankNTypes, PolymorphicComponents, ExistentialQuantification - , ScopedTypeVariables, ImplicitParams, FlexibleContexts - , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns - , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface - , Arrows, Generics, NamedFieldPuns, PatternGuards - , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms - , HereDocuments] ++ - map DisableExtension - [MonomorphismRestriction, ImplicitPrelude] ++ - compatExtensionsExtra - - -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 - -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) - compatExtensionsExtra = - map EnableExtension - [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving - , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms - , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields - , OverloadedStrings, GADTs, RelaxedPolyRec - , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable - , ConstrainedClassMethods - ] ++ - map DisableExtension - [MonoPatBinds] - - allModuleNames = - (case library pkg of - Nothing -> [] - (Just lib) -> explicitLibModules lib - ) - ++ concatMap otherModules (allBuildInfo pkg) - - allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg) - --- ------------------------------------------------------------ --- * Checks on the GenericPackageDescription --- ------------------------------------------------------------ - --- | Check the build-depends fields for any weirdness or bad practice. --- -checkPackageVersions :: GenericPackageDescription -> [PackageCheck] -checkPackageVersions pkg = - catMaybes [ - - -- Check that the version of base is bounded above. - -- For example this bans "build-depends: base >= 3". - -- It should probably be "build-depends: base >= 3 && < 4" - -- which is the same as "build-depends: base == 3.*" - check (not (boundedAbove baseDependency)) $ - PackageDistInexcusable $ - "The dependency 'build-depends: base' does not specify an upper " - ++ "bound on the version number. Each major release of the 'base' " - ++ "package changes the API in various ways and most packages will " - ++ "need some changes to compile with it. The recommended practice " - ++ "is to specify an upper bound on the version of the 'base' " - ++ "package. This ensures your package will continue to build when a " - ++ "new major version of the 'base' package is released. If you are " - ++ "not sure what upper bound to use then use the next major " - ++ "version. For example if you have tested your package with 'base' " - ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'." - - ] - where - -- TODO: What we really want to do is test if there exists any - -- configuration in which the base version is unbounded above. - -- However that's a bit tricky because there are many possible - -- configurations. As a cheap easy and safe approximation we will - -- pick a single "typical" configuration and check if that has an - -- open upper bound. To get a typical configuration we finalise - -- using no package index and the current platform. - finalised = finalizePD - mempty defaultComponentRequestedSpec (const True) - buildPlatform - (unknownCompilerInfo - (CompilerId buildCompilerFlavor nullVersion) - NoAbiTag) - [] pkg - baseDependency = case finalised of - Right (pkg', _) | not (null baseDeps) -> - foldr intersectVersionRanges anyVersion baseDeps - where - baseDeps = - [ vr | Dependency pname vr _ <- allBuildDepends pkg' - , pname == mkPackageName "base" ] - - -- Just in case finalizePD fails for any reason, - -- or if the package doesn't depend on the base package at all, - -- then we will just skip the check, since boundedAbove noVersion = True - _ -> noVersion - - -- TODO: move to Distribution.Version - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - (x:xs) -> case last (x:|xs) of - VersionInterval _ UpperBound {} -> True - VersionInterval _ NoUpperBound -> False - - -checkConditionals :: GenericPackageDescription -> [PackageCheck] -checkConditionals pkg = - catMaybes [ - - check (not $ null unknownOSs) $ - PackageDistInexcusable $ - "Unknown operating system name " - ++ commaSep (map quote unknownOSs) - - , check (not $ null unknownArches) $ - PackageDistInexcusable $ - "Unknown architecture name " - ++ commaSep (map quote unknownArches) - - , check (not $ null unknownImpls) $ - PackageDistInexcusable $ - "Unknown compiler name " - ++ commaSep (map quote unknownImpls) - ] - where - unknownOSs = [ os | OS (OtherOS os) <- conditions ] - unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] - unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] - conditions = concatMap fvs (maybeToList (condLibrary pkg)) - ++ concatMap (fvs . snd) (condSubLibraries pkg) - ++ concatMap (fvs . snd) (condForeignLibs pkg) - ++ concatMap (fvs . snd) (condExecutables pkg) - ++ concatMap (fvs . snd) (condTestSuites pkg) - ++ concatMap (fvs . snd) (condBenchmarks pkg) - fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables - compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c1 -> condfv c1 - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - -checkFlagNames :: GenericPackageDescription -> [PackageCheck] -checkFlagNames gpd - | null invalidFlagNames = [] - | otherwise = [ PackageDistInexcusable - $ "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". " - ++ "To avoid ambiguity in command line interfaces, flag shouldn't " - ++ "start with a dash. Also for better compatibility, flag names " - ++ "shouldn't contain non-ascii characters." - ] - where - invalidFlagNames = - [ fn - | flag <- genPackageFlags gpd - , let fn = unFlagName (flagName flag) - , invalidFlagName fn - ] - -- starts with dash - invalidFlagName ('-':_) = True - -- mon ascii letter - invalidFlagName cs = any (not . isAscii) cs - -checkUnusedFlags :: GenericPackageDescription -> [PackageCheck] -checkUnusedFlags gpd - | declared == used = [] - | otherwise = [ PackageDistSuspicious - $ "Declared and used flag sets differ: " - ++ s declared ++ " /= " ++ s used ++ ". " - ] - where - s :: Set.Set FlagName -> String - s = commaSep . map unFlagName . Set.toList - - declared :: Set.Set FlagName - declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd - - used :: Set.Set FlagName - used = mconcat - [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd - ] - -checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck] -checkUnicodeXFields gpd - | null nonAsciiXFields = [] - | otherwise = [ PackageDistInexcusable - $ "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". " - ++ "For better compatibility, custom field names " - ++ "shouldn't contain non-ascii characters." - ] - where - nonAsciiXFields :: [String] - nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ] - - xfields :: [(String,String)] - xfields = DList.runDList $ mconcat - [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd - , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd - ] - --- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build. -checkPathsModuleExtensions :: PackageDescription -> [PackageCheck] -checkPathsModuleExtensions pd - | specVersion pd >= CabalSpecV2_2 = [] - | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) - = return $ PackageBuildImpossible $ unwords - [ "The package uses RebindableSyntax with OverloadedStrings or OverloadedLists" - , "in default-extensions, and also Paths_ autogen module." - , "That configuration is known to cause compile failures with Cabal < 2.2." - , "To use these default-extensions with Paths_ autogen module" - , "specify at least 'cabal-version: 2.2'." - ] - | otherwise = [] - where - mn = autogenPathsModuleName pd - - checkLib :: Library -> Bool - checkLib l = mn `elem` exposedModules l && checkExts (l ^. L.defaultExtensions) - - checkBI :: BuildInfo -> Bool - checkBI bi = - (mn `elem` otherModules bi || mn `elem` autogenModules bi) && - checkExts (bi ^. L.defaultExtensions) - - checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts) - where - rebind = EnableExtension RebindableSyntax - strings = EnableExtension OverloadedStrings - lists = EnableExtension OverloadedLists - --- | Checks GHC options from all ghc-*-options fields from the given BuildInfo --- and reports flags that are OK during development process, but are --- unacceptable in a distrubuted package -checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck] -checkDevelopmentOnlyFlagsBuildInfo bi = - checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi) - ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi) - --- | Checks the given list of flags belonging to the given field and reports --- flags that are OK during development process, but are unacceptable in a --- distributed package -checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck] -checkDevelopmentOnlyFlagsOptions fieldName ghcOptions = - catMaybes [ - - check has_WerrorWall $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -Wall -Werror' makes the package very easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. Use just '" ++ fieldName ++ ": -Wall' instead." - ++ extraExplanation - - , check (not has_WerrorWall && has_Werror) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -Werror' makes the package easy to " - ++ "break with future GHC versions because new GHC versions often " - ++ "add new warnings. " - ++ extraExplanation - - , check (has_J) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup," - ++ " but it is not appropriate for a distributed package." - ++ extraExplanation - - , checkFlags ["-fdefer-type-errors"] $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development but " - ++ "is not appropriate for a distributed package. " - ++ extraExplanation - - -- -dynamic is not a debug flag - , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic") - ghcOptions) $ - PackageDistInexcusable $ - "'" ++ fieldName ++ ": -d*' debug flags are not appropriate " - ++ "for a distributed package. " - ++ extraExplanation - - , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls", - "-fprof-cafs", "-fno-prof-count-entries", - "-auto-all", "-auto", "-caf-all"] $ - PackageDistSuspicious $ - "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not " - ++ "appropriate for a distributed library package. These flags are " - ++ "useful to profile this package, but when profiling other packages " - ++ "that use this one these flags clutter the profile output with " - ++ "excessive detail. If you think other packages really want to see " - ++ "cost centres from this package then use '-fprof-auto-exported' " - ++ "which puts cost centres only on exported functions. " - ++ extraExplanation - ] - where - extraExplanation = - " Alternatively, if you want to use this, make it conditional based " - ++ "on a Cabal configuration flag (with 'manual: True' and 'default: " - ++ "False') and enable that flag during development." - - has_WerrorWall = has_Werror && ( has_Wall || has_W ) - has_Werror = "-Werror" `elem` ghcOptions - has_Wall = "-Wall" `elem` ghcOptions - has_W = "-W" `elem` ghcOptions - has_J = any - (\o -> case o of - "-j" -> True - ('-' : 'j' : d : _) -> isDigit d - _ -> False - ) - ghcOptions - checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck - checkFlags flags = check (any (`elem` flags) ghcOptions) - -checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck] -checkDevelopmentOnlyFlags pkg = - concatMap checkDevelopmentOnlyFlagsBuildInfo - [ bi - | (conditions, bi) <- allConditionalBuildInfo - , not (any guardedByManualFlag conditions) ] - where - guardedByManualFlag = definitelyFalse - - -- We've basically got three-values logic here: True, False or unknown - -- hence this pattern to propagate the unknown cases properly. - definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags) - definitelyFalse (Var _) = False - definitelyFalse (Lit b) = not b - definitelyFalse (CNot c) = definitelyTrue c - definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2 - definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2 - - definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags) - definitelyTrue (Var _) = False - definitelyTrue (Lit b) = b - definitelyTrue (CNot c) = definitelyFalse c - definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2 - definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2 - - manualFlags = Map.fromList - [ (flagName flag, flagDefault flag) - | flag <- genPackageFlags pkg - , flagManual flag ] - - allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)] - allConditionalBuildInfo = - concatMap (collectCondTreePaths libBuildInfo) - (maybeToList (condLibrary pkg)) - - ++ concatMap (collectCondTreePaths libBuildInfo . snd) - (condSubLibraries pkg) - - ++ concatMap (collectCondTreePaths buildInfo . snd) - (condExecutables pkg) - - ++ concatMap (collectCondTreePaths testBuildInfo . snd) - (condTestSuites pkg) - - ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd) - (condBenchmarks pkg) - - -- get all the leaf BuildInfo, paired up with the path (in the tree sense) - -- of if-conditions that guard it - collectCondTreePaths :: (a -> b) - -> CondTree v c a - -> [([Condition v], b)] - collectCondTreePaths mapData = go [] - where - go conditions condNode = - -- the data at this level in the tree: - (reverse conditions, mapData (condTreeData condNode)) - - : concat - [ go (condition:conditions) ifThen - | (CondBranch condition ifThen _) <- condTreeComponents condNode ] - - ++ concat - [ go (condition:conditions) elseThen - | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ] - - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Sanity check things that requires IO. It looks at the files in the --- package and expects to find the package unpacked in at the given file path. --- -checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] -checkPackageFiles verbosity pkg root = do - contentChecks <- checkPackageContent checkFilesIO pkg - preDistributionChecks <- checkPackageFilesPreDistribution verbosity pkg root - -- Sort because different platforms will provide files from - -- `getDirectoryContents` in different orders, and we'd like to be - -- stable for test output. - return (sort contentChecks ++ sort preDistributionChecks) - where - checkFilesIO = CheckPackageContentOps { - doesFileExist = System.doesFileExist . relative, - doesDirectoryExist = System.doesDirectoryExist . relative, - getDirectoryContents = System.Directory.getDirectoryContents . relative, - getFileContents = BS.readFile . relative - } - relative path = root path - --- | A record of operations needed to check the contents of packages. --- Used by 'checkPackageContent'. --- -data CheckPackageContentOps m = CheckPackageContentOps { - doesFileExist :: FilePath -> m Bool, - doesDirectoryExist :: FilePath -> m Bool, - getDirectoryContents :: FilePath -> m [FilePath], - getFileContents :: FilePath -> m BS.ByteString - } - --- | Sanity check things that requires looking at files in the package. --- This is a generalised version of 'checkPackageFiles' that can work in any --- monad for which you can provide 'CheckPackageContentOps' operations. --- --- The point of this extra generality is to allow doing checks in some virtual --- file system, for example a tarball in memory. --- -checkPackageContent :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkPackageContent ops pkg = do - cabalBomError <- checkCabalFileBOM ops - cabalNameError <- checkCabalFileName ops pkg - licenseErrors <- checkLicensesExist ops pkg - setupError <- checkSetupExists ops pkg - configureError <- checkConfigureExists ops pkg - localPathErrors <- checkLocalPathsExist ops pkg - vcsLocation <- checkMissingVcsInfo ops pkg - - return $ licenseErrors - ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError] - ++ localPathErrors - ++ vcsLocation - -checkCabalFileBOM :: Monad m => CheckPackageContentOps m - -> m (Maybe PackageCheck) -checkCabalFileBOM ops = do - epdfile <- findPackageDesc ops - case epdfile of - -- MASSIVE HACK. If the Cabal file doesn't exist, that is - -- a very strange situation to be in, because the driver code - -- in 'Distribution.Setup' ought to have noticed already! - -- But this can be an issue, see #3552 and also when - -- --cabal-file is specified. So if you can't find the file, - -- just don't bother with this check. - Left _ -> return $ Nothing - Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8) - `liftM` (getFileContents ops pdfile) - where pc = PackageDistInexcusable $ - pdfile ++ " starts with an Unicode byte order mark (BOM)." - ++ " This may cause problems with older cabal versions." - - where - bomUtf8 :: BS.ByteString - bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8 - -checkCabalFileName :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkCabalFileName ops pkg = do - -- findPackageDesc already takes care to detect missing/multiple - -- .cabal files; we don't include this check in 'findPackageDesc' in - -- order not to short-cut other checks which call 'findPackageDesc' - epdfile <- findPackageDesc ops - case epdfile of - -- see "MASSIVE HACK" note in 'checkCabalFileBOM' - Left _ -> return Nothing - Right pdfile - | takeFileName pdfile == expectedCabalname -> return Nothing - | otherwise -> return $ Just $ PackageDistInexcusable $ - "The filename " ++ pdfile ++ " does not match package name " ++ - "(expected: " ++ expectedCabalname ++ ")" - where - pkgname = unPackageName . packageName $ pkg - expectedCabalname = pkgname <.> "cabal" - - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', --- but generalized over monads. -findPackageDesc :: Monad m => CheckPackageContentOps m - -> m (Either PackageCheck FilePath) -- ^.cabal -findPackageDesc ops - = do let dir = "." - files <- getDirectoryContents ops dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist ops) - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> return (Left $ PackageBuildImpossible noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ PackageBuildImpossible - $ multiDesc multiple) - - where - noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found while checking.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - -checkLicensesExist :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLicensesExist ops pkg = do - exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg) - return - [ PackageBuildWarning $ - "The '" ++ fieldname ++ "' field refers to the file " - ++ quote (getSymbolicPath file) ++ " which does not exist." - | (file, False) <- zip (licenseFiles pkg) exists ] - where - fieldname | length (licenseFiles pkg) == 1 = "license-file" - | otherwise = "license-files" - -checkSetupExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkSetupExists ops pkg = do - let simpleBuild = buildType pkg == Simple - hsexists <- doesFileExist ops "Setup.hs" - lhsexists <- doesFileExist ops "Setup.lhs" - return $ check (not simpleBuild && not hsexists && not lhsexists) $ - PackageDistInexcusable $ - "The package is missing a Setup.hs or Setup.lhs script." - -checkConfigureExists :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m (Maybe PackageCheck) -checkConfigureExists ops pd - | buildType pd == Configure = do - exists <- doesFileExist ops "configure" - return $ check (not exists) $ - PackageBuildWarning $ - "The 'build-type' is 'Configure' but there is no 'configure' script. " - ++ "You probably need to run 'autoreconf -i' to generate it." - | otherwise = return Nothing - -checkLocalPathsExist :: Monad m => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkLocalPathsExist ops pkg = do - let dirs = [ (dir, kind) - | bi <- allBuildInfo pkg - , (dir, kind) <- - [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] - ++ [ (dir, "extra-framework-dirs") - | dir <- extraFrameworkDirs bi ] - ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] - ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] - , isRelativeOnAnyPlatform dir ] - missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs - return [ PackageBuildWarning { - explanation = quote (kind ++ ": " ++ dir) - ++ " directory does not exist." - } - | (dir, kind) <- missing ] - -checkMissingVcsInfo :: (Monad m, Applicative m) - => CheckPackageContentOps m - -> PackageDescription - -> m [PackageCheck] -checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do - vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames - if vcsInUse - then return [ PackageDistSuspicious message ] - else return [] - where - repoDirnames = [ dirname | repo <- knownRepoTypes - , dirname <- repoTypeDirname repo] - message = "When distributing packages it is encouraged to specify source " - ++ "control information in the .cabal file using one or more " - ++ "'source-repository' sections. See the Cabal user guide for " - ++ "details." - -checkMissingVcsInfo _ _ = return [] - -repoTypeDirname :: KnownRepoType -> [FilePath] -repoTypeDirname Darcs = ["_darcs"] -repoTypeDirname Git = [".git"] -repoTypeDirname SVN = [".svn"] -repoTypeDirname CVS = ["CVS"] -repoTypeDirname Mercurial = [".hg"] -repoTypeDirname GnuArch = [".arch-params"] -repoTypeDirname Bazaar = [".bzr"] -repoTypeDirname Monotone = ["_MTN"] -repoTypeDirname Pijul = [".pijul"] - --- ------------------------------------------------------------ --- * Checks involving files in the package --- ------------------------------------------------------------ - --- | Check the names of all files in a package for portability problems. This --- should be done for example when creating or validating a package tarball. --- -checkPackageFileNames :: [FilePath] -> [PackageCheck] -checkPackageFileNames files = - (take 1 . mapMaybe checkWindowsPath $ files) - ++ (take 1 . mapMaybe checkTarPath $ files) - -- If we get any of these checks triggering then we're likely to get - -- many, and that's probably not helpful, so return at most one. - -checkWindowsPath :: FilePath -> Maybe PackageCheck -checkWindowsPath path = - check (not $ FilePath.Windows.isValid path') $ - PackageDistInexcusable $ - "Unfortunately, the file " ++ quote path ++ " is not a valid file " - ++ "name on Windows which would cause portability problems for this " - ++ "package. Windows file names cannot contain any of the characters " - ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " - ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." - where - path' = ".\\" ++ path - -- force a relative name to catch invalid file names like "f:oo" which - -- otherwise parse as file "oo" in the current directory on the 'f' drive. - --- | Check a file name is valid for the portable POSIX tar format. --- --- The POSIX tar format has a restriction on the length of file names. It is --- unfortunately not a simple restriction like a maximum length. The exact --- restriction is that either the whole path be 100 characters or less, or it --- be possible to split the path on a directory separator such that the first --- part is 155 characters or less and the second part 100 characters or less. --- -checkTarPath :: FilePath -> Maybe PackageCheck -checkTarPath path - | length path > 255 = Just longPath - | otherwise = case pack nameMax (reverse (splitPath path)) of - Left err -> Just err - Right [] -> Nothing - Right (h:rest) -> case pack prefixMax remainder of - Left err -> Just err - Right [] -> Nothing - Right (_:_) -> Just noSplit - where - -- drop the '/' between the name and prefix: - remainder = safeInit h : rest - - where - nameMax, prefixMax :: Int - nameMax = 100 - prefixMax = 155 - - pack _ [] = Left emptyName - pack maxLen (c:cs) - | n > maxLen = Left longName - | otherwise = Right (pack' maxLen n cs) - where n = length c - - pack' maxLen n (c:cs) - | n' <= maxLen = pack' maxLen n' cs - where n' = n + length c - pack' _ _ cs = cs - - longPath = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length is 255 ASCII characters.\n" - ++ "The file in question is:\n " ++ path - longName = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. The maximum length for the name part (including " - ++ "extension) is 100 ASCII characters. The maximum length for any " - ++ "individual directory component is 155.\n" - ++ "The file in question is:\n " ++ path - noSplit = PackageDistInexcusable $ - "The following file name is too long to store in a portable POSIX " - ++ "format tar archive. While the total length is less than 255 ASCII " - ++ "characters, there are unfortunately further restrictions. It has to " - ++ "be possible to split the file path on a directory separator into " - ++ "two parts such that the first part fits in 155 characters or less " - ++ "and the second part fits in 100 characters or less. Basically you " - ++ "have to make the file name or directory names shorter, or you could " - ++ "split a long directory name into nested subdirectories with shorter " - ++ "names.\nThe file in question is:\n " ++ path - emptyName = PackageDistInexcusable $ - "Encountered a file with an empty name, something is very wrong! " - ++ "Files with an empty name cannot be stored in a tar archive or in " - ++ "standard file systems." - --- -------------------------------------------------------------- --- * Checks for missing content and other pre-distribution checks --- -------------------------------------------------------------- - --- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution' --- inspects the files included in the package, but is primarily looking for --- files in the working tree that may have been missed or other similar --- problems that can only be detected pre-distribution. --- --- Because Hackage necessarily checks the uploaded tarball, it is too late to --- check these on the server; these checks only make sense in the development --- and package-creation environment. Hence we can use IO, rather than needing --- to pass a 'CheckPackageContentOps' dictionary around. -checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck] --- Note: this really shouldn't return any 'Inexcusable' warnings, --- because that will make us say that Hackage would reject the package. --- But, because Hackage doesn't run these tests, that will be a lie! -checkPackageFilesPreDistribution = checkGlobFiles - --- | Discover problems with the package's wildcards. -checkGlobFiles :: Verbosity - -> PackageDescription - -> FilePath - -> IO [PackageCheck] -checkGlobFiles verbosity pkg root = - fmap concat $ for allGlobs $ \(field, dir, glob) -> - -- Note: we just skip over parse errors here; they're reported elsewhere. - case parseFileGlob (specVersion pkg) glob of - Left _ -> return [] - Right parsedGlob -> do - results <- runDirFileGlob verbosity (root dir) parsedGlob - let individualWarnings = results >>= getWarning field glob - noMatchesWarning = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match any files." - | all (not . suppressesNoMatchesWarning) results - ] - return (noMatchesWarning ++ individualWarnings) - where - adjustedDataDir = if null (dataDir pkg) then "." else dataDir pkg - allGlobs = concat - [ (,,) "extra-source-files" "." <$> extraSrcFiles pkg - , (,,) "extra-doc-files" "." <$> extraDocFiles pkg - , (,,) "data-files" adjustedDataDir <$> dataFiles pkg - ] - - -- If there's a missing directory in play, since our globs don't - -- (currently) support disjunction, that will always mean there are no - -- matches. The no matches error in this case is strictly less informative - -- than the missing directory error, so sit on it. - suppressesNoMatchesWarning (GlobMatch _) = True - suppressesNoMatchesWarning (GlobWarnMultiDot _) = False - suppressesNoMatchesWarning (GlobMissingDirectory _) = True - - getWarning :: String -> FilePath -> GlobResult FilePath -> [PackageCheck] - getWarning _ _ (GlobMatch _) = - [] - -- Before Cabal 2.4, the extensions of globs had to match the file - -- exactly. This has been relaxed in 2.4 to allow matching only the - -- suffix. This warning detects when pre-2.4 package descriptions are - -- omitting files purely because of the stricter check. - getWarning field glob (GlobWarnMultiDot file) = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not" - ++ " match the file '" ++ file ++ "' because the extensions do not" - ++ " exactly match (e.g., foo.en.html does not exactly match *.html)." - ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or higher." - ] - getWarning field glob (GlobMissingDirectory dir) = - [ PackageDistSuspiciousWarn $ - "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to" - ++ " match files in the directory '" ++ dir ++ "', but there is no" - ++ " directory by that name." - ] - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -quote :: String -> String -quote s = "'" ++ s ++ "'" - -commaSep :: [String] -> String -commaSep = intercalate ", " - -dups :: Ord a => [a] -> [a] -dups xs = [ x | (x:_:_) <- group (sort xs) ] - -fileExtensionSupportedLanguage :: FilePath -> Bool -fileExtensionSupportedLanguage path = - isHaskell || isC - where - extension = takeExtension path - isHaskell = extension `elem` [".hs", ".lhs"] - isC = isJust (filenameCDialect extension) - --- | Whether a path is a good relative path. --- --- >>> let test fp = putStrLn $ show (isGoodRelativeDirectoryPath fp) ++ "; " ++ show (isGoodRelativeFilePath fp) --- --- >>> test "foo/bar/quu" --- Nothing; Nothing --- --- Trailing slash is not allowed for files, for directories it is ok. --- --- >>> test "foo/" --- Nothing; Just "trailing slash" --- --- Leading @./@ is fine, but @.@ and @./@ are not valid files. --- --- >>> traverse_ test [".", "./", "./foo/bar"] --- Nothing; Just "trailing dot segment" --- Nothing; Just "trailing slash" --- Nothing; Nothing --- --- Lastly, not good file nor directory cases: --- --- >>> traverse_ test ["", "/tmp/src", "foo//bar", "foo/.", "foo/./bar", "foo/../bar", "foo*bar"] --- Just "empty path"; Just "empty path" --- Just "posix absolute path"; Just "posix absolute path" --- Just "empty path segment"; Just "empty path segment" --- Just "trailing same directory segment: ."; Just "trailing same directory segment: ." --- Just "same directory segment: ."; Just "same directory segment: .." --- Just "parent directory segment: .."; Just "parent directory segment: .." --- Just "reserved character '*'"; Just "reserved character '*'" --- --- For the last case, 'isGoodRelativeGlob' doesn't warn: --- --- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar", "foo*bar"] --- Just "parent directory segment: .." --- Nothing --- -isGoodRelativeFilePath :: FilePath -> Maybe String -isGoodRelativeFilePath = state0 - where - -- Reserved characters - -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file - isReserved c = c `elem` "<>:\"\\/|?*" - - -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state1 cs - | c == '/' = Just "posix absolute path" - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state3 cs - - -- after . - state1 [] = Just "trailing dot segment" - state1 (c:cs) | c == '.' = state4 cs - | c == '/' = state2 cs - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state5 cs - - -- after ./ - state2 [] = Just "trailing slash" - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "empty path segment" - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state5 cs - - -- after non-first segment's . - state3 [] = Just "trailing same directory segment: ." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "same directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state5 cs - - -- after non-first segment's .. - state4 [] = Just "trailing parent directory segment: .." - state4 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "parent directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state5 cs - - -- in a segment which is ok. - state5 [] = Nothing - state5 (c:cs) | c == '.' = state3 cs - | c == '/' = state2 cs - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state5 cs - --- | See 'isGoodRelativeFilePath'. --- --- This is barebones function. We check whether the glob is a valid file --- by replacing stars @*@ with @x@ses. -isGoodRelativeGlob :: FilePath -> Maybe String -isGoodRelativeGlob = isGoodRelativeFilePath . map f where - f '*' = 'x' - f c = c - --- | See 'isGoodRelativeFilePath'. -isGoodRelativeDirectoryPath :: FilePath -> Maybe String -isGoodRelativeDirectoryPath = state0 - where - -- Reserved characters - -- https://docs.microsoft.com/en-us/windows/win32/fileio/naming-a-file - isReserved c = c `elem` "<>:\"\\/|?*" - - -- initial state - state0 [] = Just "empty path" - state0 (c:cs) | c == '.' = state5 cs - | c == '/' = Just "posix absolute path" - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - - -- after ./ - state1 [] = Nothing -- "./" - state1 (c:cs) | c == '.' = state2 cs - | c == '/' = Just "empty path segment" - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - - -- after non-first setgment's . - state2 [] = Just "trailing same directory segment: ." - state2 (c:cs) | c == '.' = state3 cs - | c == '/' = Just "same directory segment: ." - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - - -- after non-first segment's .. - state3 [] = Just "trailing parent directory segment: ." - state3 (c:cs) | c == '.' = state4 cs - | c == '/' = Just "parent directory segment: .." - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - - -- in a segment which is ok. - state4 [] = Nothing - state4 (c:cs) | c == '.' = state4 cs - | c == '/' = state1 cs - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - - -- after . - state5 [] = Nothing -- "." - state5 (c:cs) | c == '.' = state3 cs - | c == '/' = state1 cs - | isReserved c = Just ("reserved character " ++ show c) - | otherwise = state4 cs - --- [Note: Good relative paths] --- --- Using @kleene@ we can define an extended regex: --- --- @ --- import Algebra.Lattice --- import Kleene --- import Kleene.ERE (ERE (..), intersections) --- --- data C = CDot | CSlash | COtherReserved | CChar --- deriving (Eq, Ord, Enum, Bounded, Show) --- --- reservedR :: ERE C --- reservedR = notChar CSlash /\ notChar COtherReserved --- --- pathPieceR :: ERE C --- pathPieceR = intersections --- [ plus reservedR --- , ERENot (string [CDot]) --- , ERENot (string [CDot,CDot]) --- ] --- --- filePathR :: ERE C --- filePathR = optional (string [CDot, CSlash]) <> pathPieceR <> star (char CSlash <> pathPieceR) --- --- dirPathR :: ERE C --- dirPathR = (char CDot \/ filePathR) <> optional (char CSlash) --- --- plus :: ERE C -> ERE C --- plus r = r <> star r --- --- optional :: ERE C -> ERE C --- optional r = mempty \/ r --- @ --- --- Results in following state machine for @filePathR@ --- --- @ --- 0 -> \x -> if --- | x <= CDot -> 1 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 1 -> \x -> if --- | x <= CDot -> 4 --- | x <= CSlash -> 2 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 2 -> \x -> if --- | x <= CDot -> 3 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 3 -> \x -> if --- | x <= CDot -> 4 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 4 -> \x -> if --- | x <= CDot -> 5 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 5+ -> \x -> if --- | x <= CDot -> 5 --- | x <= CSlash -> 2 --- | x <= COtherReserved -> 6 --- | otherwise -> 5 --- 6 -> \_ -> 6 -- black hole --- @ --- --- and @dirPathR@: --- --- @ --- 0 -> \x -> if --- | x <= CDot -> 5 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 1+ -> \x -> if --- | x <= CDot -> 2 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 2 -> \x -> if --- | x <= CDot -> 3 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 3 -> \x -> if --- | x <= CDot -> 4 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 4+ -> \x -> if --- | x <= CDot -> 4 --- | x <= CSlash -> 1 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 5+ -> \x -> if --- | x <= CDot -> 3 --- | x <= CSlash -> 1 --- | x <= COtherReserved -> 6 --- | otherwise -> 4 --- 6 -> \_ -> 6 -- black hole --- @ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2022 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of checks so we can see which ones are appropriate to report +-- in different situations. This code gets used when configuring a package when +-- we consider only basic problems. The higher standard is used when +-- preparing a source tarball and by Hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. +module Distribution.PackageDescription.Check + ( -- * Package Checking + CheckExplanation (..) + , CheckExplanationID + , CheckExplanationIDString + , PackageCheck (..) + , checkPackage + , checkConfiguredPackage + , wrapParseWarning + , ppPackageCheck + , ppCheckExplanationId + , isHackageDistError + , filterPackageChecksById + , filterPackageChecksByIdString + + -- ** Checking package contents + , checkPackageFiles + , checkPackageFilesGPD + , checkPackageContent + , CheckPackageContentOps (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.List (group) +import Distribution.CabalSpecVersion +import Distribution.Compat.Lens +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check.Common +import Distribution.PackageDescription.Check.Conditional +import Distribution.PackageDescription.Check.Monad +import Distribution.PackageDescription.Check.Paths +import Distribution.PackageDescription.Check.Target +import Distribution.PackageDescription.Check.Warning +import Distribution.Parsec.Warning (PWarning) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.Glob + ( Glob + , GlobResult (..) + , globMatches + , parseFileGlob + , runDirFileGlob + ) +import Distribution.Simple.Utils hiding (findPackageDesc, notice) +import Distribution.Utils.Generic (isAscii) +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import System.FilePath (splitExtension, takeFileName) + +import qualified Data.ByteString.Lazy as BS +import qualified Distribution.SPDX as SPDX +import qualified System.Directory as System + +import qualified System.Directory (getDirectoryContents) +import qualified System.FilePath.Windows as FilePath.Windows (isValid) + +import qualified Data.Set as Set +import qualified Distribution.Utils.ShortText as ShortText + +import qualified Distribution.Types.GenericPackageDescription.Lens as L + +import Control.Monad + +-- $setup +-- >>> import Control.Arrow ((&&&)) + +-- ☞ N.B. +-- +-- Part of the tools/scaffold used to perform check is found in +-- Distribution.PackageDescription.Check.Types. Summary of that module (for +-- how we use it here): +-- 1. we work inside a 'CheckM m a' monad (where `m` is an abstraction to +-- run non-pure checks); +-- 2. 'checkP', 'checkPre' functions perform checks (respectively pure and +-- non-pure); +-- 3. 'PackageCheck' and 'CheckExplanation' are types for warning severity +-- and description. + +-- ------------------------------------------------------------ +-- Checking interface +-- ------------------------------------------------------------ + +-- | 'checkPackagePrim' is the most general way to invoke package checks. +-- We pass to it two interfaces (one to check contents of packages, the +-- other to inspect working tree for orphan files) and before that a +-- Boolean to indicate whether we want pure checks or not. Based on these +-- parameters, some checks will be performed, some omitted. +-- Generality over @m@ means we could do non pure checks in monads other +-- than IO (e.g. a virtual filesystem, like a zip file, a VCS filesystem, +-- etc). +checkPackagePrim + :: Monad m + => Bool -- Perform pure checks? + -> Maybe (CheckPackageContentOps m) -- Package content interface. + -> Maybe (CheckPreDistributionOps m) -- Predist checks interface. + -> GenericPackageDescription -- GPD to check. + -> m [PackageCheck] +checkPackagePrim b mco mpdo gpd = do + let cm = checkGenericPackageDescription gpd + ci = CheckInterface b mco mpdo + ctx = pristineCheckCtx ci gpd + execCheckM cm ctx + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all aspects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +checkPackage :: GenericPackageDescription -> [PackageCheck] +checkPackage gpd = runIdentity $ checkPackagePrim True Nothing Nothing gpd + +-- | This function is an oddity due to the historical +-- GenericPackageDescription/PackageDescription split. It is only maintained +-- not to break interface, use `checkPackage` if possible. +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pd = checkPackage (pd2gpd pd) + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +checkPackageContent + :: Monad m + => CheckPackageContentOps m + -> GenericPackageDescription + -> m [PackageCheck] +checkPackageContent pops gpd = checkPackagePrim False (Just pops) Nothing gpd + +-- | Sanity checks that require IO. 'checkPackageFiles' looks at the files +-- in the package and expects to find the package unpacked at the given +-- filepath. +checkPackageFilesGPD + :: Verbosity -- Glob warn message verbosity. + -> GenericPackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFilesGPD verbosity gpd root = + checkPackagePrim False (Just checkFilesIO) (Just checkPreIO) gpd + where + checkFilesIO = + CheckPackageContentOps + { doesFileExist = System.doesFileExist . relative + , doesDirectoryExist = System.doesDirectoryExist . relative + , getDirectoryContents = System.Directory.getDirectoryContents . relative + , getFileContents = BS.readFile . relative + } + + checkPreIO = + CheckPreDistributionOps + { runDirFileGlobM = \fp g -> runDirFileGlob verbosity (Just . specVersion $ packageDescription gpd) (root fp) g + , getDirectoryContentsM = System.Directory.getDirectoryContents . relative + } + + relative :: FilePath -> FilePath + relative path = root path + +-- | Same as 'checkPackageFilesGPD', but working with 'PackageDescription'. +-- +-- This function is included for legacy reasons, use 'checkPackageFilesGPD' +-- if you are working with 'GenericPackageDescription'. +checkPackageFiles + :: Verbosity -- Glob warn message verbosity. + -> PackageDescription + -> FilePath -- Package root. + -> IO [PackageCheck] +checkPackageFiles verbosity pd oot = + checkPackageFilesGPD verbosity (pd2gpd pd) oot + +-- ------------------------------------------------------------ +-- Package description +-- ------------------------------------------------------------ + +-- Here lies the meat of the module. Starting from 'GenericPackageDescription', +-- we walk the data while doing a number of checks. +-- +-- Where applicable we do a full pattern match (if the data changes, code will +-- break: a gentle reminder to add more checks). +-- Pattern matching variables convention: matching accessor + underscore. +-- This way it is easier to see which one we are missing if we run into +-- an “GPD should have 20 arguments but has been given only 19” error. + +-- | 'GenericPackageDescription' checks. Remember that for historical quirks +-- in the cabal codebase we have both `GenericPackageDescription` and +-- `PackageDescription` and that PD is both a *field* of GPD and a concept +-- of its own (i.e. a fully realised GPD). +-- In this case we are checking (correctly) GPD, so for target info/checks +-- you should walk condLibrary_ etc. and *not* the (empty) target info in +-- PD. See 'pd2gpd' for a convenient hack when you only have +-- 'PackageDescription'. +checkGenericPackageDescription + :: Monad m + => GenericPackageDescription + -> CheckM m () +checkGenericPackageDescription + gpd@( GenericPackageDescription + packageDescription_ + _gpdScannedVersion_ + genPackageFlags_ + condLibrary_ + condSubLibraries_ + condForeignLibs_ + condExecutables_ + condTestSuites_ + condBenchmarks_ + ) = + do + -- § Description and names. + checkPackageDescription packageDescription_ + -- Targets should be present... + let condAllLibraries = + maybeToList condLibrary_ + ++ (map snd condSubLibraries_) + checkP + ( and + [ null condExecutables_ + , null condTestSuites_ + , null condBenchmarks_ + , null condAllLibraries + , null condForeignLibs_ + ] + ) + (PackageBuildImpossible NoTarget) + -- ... and have unique names (names are not under conditional, it is + -- appropriate to check here. + (nsubs, nexes, ntests, nbenchs) <- + asksCM + ( ( \n -> + ( pnSubLibs n + , pnExecs n + , pnTests n + , pnBenchs n + ) + ) + . ccNames + ) + let names = concat [nsubs, nexes, ntests, nbenchs] + dupes = dups names + checkP + (not . null $ dups names) + (PackageBuildImpossible $ DuplicateSections dupes) + -- Flag names. + mapM_ checkFlagName genPackageFlags_ + + -- § Feature checks. + checkSpecVer + CabalSpecV2_0 + (not . null $ condSubLibraries_) + (PackageDistInexcusable CVMultiLib) + checkSpecVer + CabalSpecV1_8 + (not . null $ condTestSuites_) + (PackageDistInexcusable CVTestSuite) + + -- § Conditional targets + + -- Extract dependencies from libraries, to be passed along for + -- PVP checks purposes. + pName <- + asksCM + ( packageNameToUnqualComponentName + . pkgName + . pnPackageId + . ccNames + ) + let ads = + maybe [] ((: []) . extractAssocDeps pName) condLibrary_ + ++ map (uncurry extractAssocDeps) condSubLibraries_ + + case condLibrary_ of + Just cl -> + checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (const id) + (mempty, cl) + Nothing -> return () + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkLibrary False ads) + (\u l -> l{libName = maybeToLibraryName (Just u)}) + ) + condSubLibraries_ + mapM_ + ( checkCondTarget + genPackageFlags_ + checkForeignLib + (const id) + ) + condForeignLibs_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkExecutable ads) + (const id) + ) + condExecutables_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkTestSuite ads) + (\u l -> l{testName = u}) + ) + condTestSuites_ + mapM_ + ( checkCondTarget + genPackageFlags_ + (checkBenchmark ads) + (\u l -> l{benchmarkName = u}) + ) + condBenchmarks_ + + -- For unused flags it is clearer and more convenient to fold the + -- data rather than walk it, an exception to the rule. + checkP + (decFlags /= usedFlags) + (PackageDistSuspicious $ DeclaredUsedFlags decFlags usedFlags) + + -- Duplicate modules. + mapM_ tellP (checkDuplicateModules gpd) + where + -- todo is this caught at parse time? + checkFlagName :: Monad m => PackageFlag -> CheckM m () + checkFlagName pf = + let fn = unFlagName . flagName $ pf + + invalidFlagName ('-' : _) = True -- starts with dash + invalidFlagName cs = any (not . isAscii) cs -- non ASCII + in checkP + (invalidFlagName fn) + (PackageDistInexcusable $ SuspiciousFlagName [fn]) + + decFlags :: Set.Set FlagName + decFlags = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd + + usedFlags :: Set.Set FlagName + usedFlags = + mconcat + [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd + ] + +checkPackageDescription :: Monad m => PackageDescription -> CheckM m () +checkPackageDescription + pkg@( PackageDescription + specVersion_ + package_ + licenseRaw_ + licenseFiles_ + _copyright_ + maintainer_ + _author_ + _stability_ + testedWith_ + _homepage_ + _pkgUrl_ + _bugReports_ + sourceRepos_ + synopsis_ + description_ + category_ + customFieldsPD_ + buildTypeRaw_ + setupBuildInfo_ + _library_ + _subLibraries_ + _executables_ + _foreignLibs_ + _testSuites_ + _benchmarks_ + dataFiles_ + dataDir_ + extraSrcFiles_ + extraTmpFiles_ + extraDocFiles_ + extraFiles_ + ) = do + -- § Sanity checks. + checkPackageId package_ + -- TODO `name` is caught at parse level, remove this test. + let pn = packageName package_ + checkP + (null . unPackageName $ pn) + (PackageBuildImpossible NoNameField) + -- TODO `version` is caught at parse level, remove this test. + checkP + (nullVersion == packageVersion package_) + (PackageBuildImpossible NoVersionField) + -- But it is OK for executables to have the same name. + nsubs <- asksCM (pnSubLibs . ccNames) + checkP + (any (== prettyShow pn) (prettyShow <$> nsubs)) + (PackageBuildImpossible $ IllegalLibraryName pn) + + -- § Fields check. + checkNull + category_ + (PackageDistSuspicious MissingFieldCategory) + checkNull + maintainer_ + (PackageDistSuspicious MissingFieldMaintainer) + checkP + (ShortText.null synopsis_ && not (ShortText.null description_)) + (PackageDistSuspicious MissingFieldSynopsis) + checkP + (ShortText.null description_ && not (ShortText.null synopsis_)) + (PackageDistSuspicious MissingFieldDescription) + checkP + (all ShortText.null [synopsis_, description_]) + (PackageDistInexcusable MissingFieldSynOrDesc) + checkP + (ShortText.length synopsis_ > 80) + (PackageDistSuspicious SynopsisTooLong) + checkP + ( not (ShortText.null description_) + && ShortText.length description_ <= ShortText.length synopsis_ + ) + (PackageDistSuspicious ShortDesc) + + -- § Paths. + mapM_ (checkPath False "extra-source-files" PathKindGlob . getSymbolicPath) extraSrcFiles_ + mapM_ (checkPath False "extra-tmp-files" PathKindFile . getSymbolicPath) extraTmpFiles_ + mapM_ (checkPath False "extra-doc-files" PathKindGlob . getSymbolicPath) extraDocFiles_ + mapM_ (checkPath False "extra-files" PathKindGlob . getSymbolicPath) extraFiles_ + mapM_ (checkPath False "data-files" PathKindGlob . getSymbolicPath) dataFiles_ + let rawDataDir = getSymbolicPath dataDir_ + checkPath True "data-dir" PathKindDirectory rawDataDir + let licPaths = map getSymbolicPath licenseFiles_ + mapM_ (checkPath False "license-file" PathKindFile) licPaths + mapM_ checkLicFileExist licenseFiles_ + + -- § Globs. + dataGlobs <- mapM (checkGlob "data-files" . getSymbolicPath) dataFiles_ + extraSrcGlobs <- mapM (checkGlob "extra-source-files" . getSymbolicPath) extraSrcFiles_ + docGlobs <- mapM (checkGlob "extra-doc-files" . getSymbolicPath) extraDocFiles_ + extraGlobs <- mapM (checkGlob "extra-files" . getSymbolicPath) extraFiles_ + -- We collect globs to feed them to checkMissingDocs. + + -- § Missing documentation. + checkMissingDocs + (catMaybes dataGlobs) + (catMaybes extraSrcGlobs) + (catMaybes docGlobs) + (catMaybes extraGlobs) + + -- § Datafield checks. + checkSetupBuildInfo setupBuildInfo_ + mapM_ checkTestedWith testedWith_ + either + checkNewLicense + (checkOldLicense $ null licenseFiles_) + licenseRaw_ + checkSourceRepos sourceRepos_ + mapM_ checkCustomField customFieldsPD_ + + -- Feature checks. + checkSpecVer + CabalSpecV1_18 + (not . null $ extraDocFiles_) + (PackageDistInexcusable CVExtraDocFiles) + checkSpecVer + CabalSpecV1_6 + (not . null $ sourceRepos_) + (PackageDistInexcusable CVSourceRepository) + checkP + ( specVersion_ >= CabalSpecV1_24 + && isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageBuildWarning CVCustomSetup) + checkSpecVer + CabalSpecV1_24 + ( isNothing setupBuildInfo_ + && buildTypeRaw_ == Just Custom + ) + (PackageDistSuspiciousWarn CVExpliticDepsCustomSetup) + checkP + (isNothing buildTypeRaw_ && specVersion_ < CabalSpecV2_2) + (PackageBuildWarning NoBuildType) + checkP + (isJust setupBuildInfo_ && buildType pkg `notElem` [Custom, Hooks]) + (PackageBuildWarning NoCustomSetup) + + -- Contents. + checkConfigureExists (buildType pkg) + checkSetupExists (buildType pkg) + checkCabalFile (packageName pkg) + mapM_ (checkGlobFile specVersion_ "." "extra-source-files" . getSymbolicPath) extraSrcFiles_ + mapM_ (checkGlobFile specVersion_ "." "extra-doc-files" . getSymbolicPath) extraDocFiles_ + mapM_ (checkGlobFile specVersion_ "." "extra-files" . getSymbolicPath) extraFiles_ + mapM_ (checkGlobFile specVersion_ rawDataDir "data-files" . getSymbolicPath) dataFiles_ + where + checkNull + :: Monad m + => ShortText.ShortText + -> PackageCheck + -> CheckM m () + checkNull st c = checkP (ShortText.null st) c + + checkTestedWith + :: Monad m + => (CompilerFlavor, VersionRange) + -> CheckM m () + checkTestedWith (OtherCompiler n, _) = + tellP (PackageBuildWarning $ UnknownCompilers [n]) + checkTestedWith (compiler, versionRange) = + checkVersionRange compiler versionRange + + checkVersionRange + :: Monad m + => CompilerFlavor + -> VersionRange + -> CheckM m () + checkVersionRange cmp vr = + when + (isNoVersion vr) + ( let dep = + [ Dependency + (mkPackageName (prettyShow cmp)) + vr + mainLibSet + ] + in tellP (PackageDistInexcusable (InvalidTestWith dep)) + ) + +checkSetupBuildInfo :: Monad m => Maybe SetupBuildInfo -> CheckM m () +checkSetupBuildInfo Nothing = return () +checkSetupBuildInfo (Just (SetupBuildInfo ds _)) = do + let uqs = map mkUnqualComponentName ["base", "Cabal"] + (is, rs) <- partitionDeps [] uqs ds + let ick = PackageDistInexcusable . UpperBoundSetup + rck = + PackageDistSuspiciousWarn + . MissingUpperBounds CETSetup + leuck = + PackageDistSuspiciousWarn + . LEUpperBounds CETSetup + tzuck = + PackageDistSuspiciousWarn + . TrailingZeroUpperBounds CETSetup + gtlck = + PackageDistSuspiciousWarn + . GTLowerBounds CETSetup + checkPVP (checkDependencyVersionRange $ not . hasUpperBound) ick is + checkPVPs (checkDependencyVersionRange $ not . hasUpperBound) rck rs + checkPVPs (checkDependencyVersionRange hasLEUpperBound) leuck ds + checkPVPs (checkDependencyVersionRange hasTrailingZeroUpperBound) tzuck ds + checkPVPs (checkDependencyVersionRange hasGTLowerBound) gtlck ds + +checkPackageId :: Monad m => PackageIdentifier -> CheckM m () +checkPackageId (PackageIdentifier pkgName_ _pkgVersion_) = do + checkP + (not . FilePath.Windows.isValid . prettyShow $ pkgName_) + (PackageDistInexcusable $ InvalidNameWin pkgName_) + checkP (isPrefixOf "z-" . prettyShow $ pkgName_) $ + (PackageDistInexcusable ZPrefix) + +checkNewLicense :: Monad m => SPDX.License -> CheckM m () +checkNewLicense lic = do + checkP + (lic == SPDX.NONE) + (PackageDistInexcusable NONELicense) + +checkOldLicense + :: Monad m + => Bool -- Flag: no license file? + -> License + -> CheckM m () +checkOldLicense nullLicFiles lic = do + checkP + (lic == UnspecifiedLicense) + (PackageDistInexcusable NoLicense) + checkP + (lic == AllRightsReserved) + (PackageDistSuspicious AllRightsReservedLicense) + checkSpecVer + CabalSpecV1_4 + (lic `notElem` compatLicenses) + (PackageDistInexcusable (LicenseMessParse lic)) + checkP + (lic == BSD4) + (PackageDistSuspicious UncommonBSD4) + case lic of + UnknownLicense l -> + tellP (PackageBuildWarning (UnrecognisedLicense l)) + _ -> return () + checkP + ( lic + `notElem` [ AllRightsReserved + , UnspecifiedLicense + , PublicDomain + ] + && + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + nullLicFiles + ) + $ (PackageDistSuspicious NoLicenseFile) + case unknownLicenseVersion lic of + Just knownVersions -> + tellP + (PackageDistSuspicious $ UnknownLicenseVersion lic knownVersions) + _ -> return () + where + compatLicenses = + [ GPL Nothing + , LGPL Nothing + , AGPL Nothing + , BSD3 + , BSD4 + , PublicDomain + , AllRightsReserved + , UnspecifiedLicense + , OtherLicense + ] + + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | GPL (Just v') <- knownLicenses] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | LGPL (Just v') <- knownLicenses] + unknownLicenseVersion (AGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | AGPL (Just v') <- knownLicenses] + unknownLicenseVersion (Apache (Just v)) + | v `notElem` knownVersions = Just knownVersions + where + knownVersions = [v' | Apache (Just v') <- knownLicenses] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: Monad m => [SourceRepo] -> CheckM m () +checkSourceRepos rs = do + mapM_ repoCheck rs + checkMissingVcsInfo rs + where + -- Single repository checks. + repoCheck :: Monad m => SourceRepo -> CheckM m () + repoCheck + ( SourceRepo + repoKind_ + repoType_ + repoLocation_ + repoModule_ + _repoBranch_ + repoTag_ + repoSubdir_ + ) = do + case repoKind_ of + RepoKindUnknown kind -> + tellP + (PackageDistInexcusable $ UnrecognisedSourceRepo kind) + _ -> return () + checkP + (isNothing repoType_) + (PackageDistInexcusable MissingType) + checkP + (isNothing repoLocation_) + (PackageDistInexcusable MissingLocation) + checkGitProtocol repoLocation_ + checkP + ( repoType_ == Just (KnownRepoType CVS) + && isNothing repoModule_ + ) + (PackageDistInexcusable MissingModule) + checkP + (repoKind_ == RepoThis && isNothing repoTag_) + (PackageDistInexcusable MissingTag) + checkP + (any isAbsoluteOnAnyPlatform repoSubdir_) + (PackageDistInexcusable SubdirRelPath) + case join . fmap isGoodRelativeDirectoryPath $ repoSubdir_ of + Just err -> + tellP + (PackageDistInexcusable $ SubdirGoodRelPath err) + Nothing -> return () + +checkMissingVcsInfo :: Monad m => [SourceRepo] -> CheckM m () +checkMissingVcsInfo rs = + let rdirs = concatMap repoTypeDirname knownRepoTypes + in checkPkg + ( \ops -> do + us <- or <$> traverse (doesDirectoryExist ops) rdirs + return (null rs && us) + ) + (PackageDistSuspicious MissingSourceControl) + where + repoTypeDirname :: KnownRepoType -> [FilePath] + repoTypeDirname Darcs = ["_darcs"] + repoTypeDirname Git = [".git"] + repoTypeDirname SVN = [".svn"] + repoTypeDirname CVS = ["CVS"] + repoTypeDirname Mercurial = [".hg"] + repoTypeDirname GnuArch = [".arch-params"] + repoTypeDirname Bazaar = [".bzr"] + repoTypeDirname Monotone = ["_MTN"] + repoTypeDirname Pijul = [".pijul"] + +-- git:// lacks TLS or other encryption, see +-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4 +checkGitProtocol + :: Monad m + => Maybe String -- Repository location + -> CheckM m () +checkGitProtocol mloc = + checkP + (fmap (isPrefixOf "git://") mloc == Just True) + (PackageBuildWarning GitProtocol) + +-- ------------------------------------------------------------ +-- Package and distribution checks +-- ------------------------------------------------------------ + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc', +-- but generalized over monads. +findPackageDesc :: Monad m => CheckPackageContentOps m -> m [FilePath] +findPackageDesc ops = do + let dir = "." + files <- getDirectoryContents ops dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .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)] diff --git a/src/Distribution/PackageDescription/Check/Common.hs b/src/Distribution/PackageDescription/Check/Common.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Common.hs @@ -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 diff --git a/src/Distribution/PackageDescription/Check/Conditional.hs b/src/Distribution/PackageDescription/Check/Conditional.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Conditional.hs @@ -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 [] diff --git a/src/Distribution/PackageDescription/Check/Monad.hs b/src/Distribution/PackageDescription/Check/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Monad.hs @@ -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) diff --git a/src/Distribution/PackageDescription/Check/Paths.hs b/src/Distribution/PackageDescription/Check/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Paths.hs @@ -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 +-- @ diff --git a/src/Distribution/PackageDescription/Check/Target.hs b/src/Distribution/PackageDescription/Check/Target.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Target.hs @@ -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 diff --git a/src/Distribution/PackageDescription/Check/Warning.hs b/src/Distribution/PackageDescription/Check/Warning.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/PackageDescription/Check/Warning.hs @@ -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 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 .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." diff --git a/src/Distribution/PackageDescription/Configuration.hs b/src/Distribution/PackageDescription/Configuration.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Configuration.hs +++ /dev/null @@ -1,600 +0,0 @@ --- -fno-warn-deprecations for use of Map.foldWithKey -{-# OPTIONS_GHC -fno-warn-deprecations #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Configuration --- Copyright : Thomas Schilling, 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is about the cabal configurations feature. It exports --- 'finalizePD' and 'flattenPackageDescription' which are --- functions for converting 'GenericPackageDescription's down to --- 'PackageDescription's. It has code for working with the tree of conditions --- and resolving or flattening conditions. - -module Distribution.PackageDescription.Configuration ( - finalizePD, - flattenPackageDescription, - - -- Utils - parseCondition, - freeVars, - extractCondition, - extractConditions, - addBuildableCondition, - mapCondTree, - mapTreeData, - mapTreeConds, - mapTreeConstrs, - transformAllBuildInfos, - transformAllBuildDepends, - transformAllBuildDependsN, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Distribution.Compat.CharParsing hiding (char) -import qualified Distribution.Compat.CharParsing as P -import Distribution.Compat.Lens -import Distribution.Compiler -import Distribution.PackageDescription -import Distribution.PackageDescription.Utils -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Types.Component -import Distribution.Utils.Path -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.DependencyMap -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map -import Data.Tree (Tree (Node)) - ------------------------------------------------------------------------------- - --- | Simplify a configuration condition using the OS and arch names. Returns --- the names of all the flags occurring in the condition. -simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar - -> (Condition FlagName, [FlagName]) -simplifyWithSysParams os arch cinfo cond = (cond', flags) - where - (cond', flags) = simplifyCondition cond interp - interp (OS os') = Right $ os' == os - interp (Arch arch') = Right $ arch' == arch - interp (Impl comp vr) - | matchImpl (compilerInfoId cinfo) = Right True - | otherwise = case compilerInfoCompat cinfo of - -- fixme: treat Nothing as unknown, rather than empty list once we - -- support partial resolution of system parameters - Nothing -> Right False - Just compat -> Right (any matchImpl compat) - where - matchImpl (CompilerId c v) = comp == c && v `withinRange` vr - interp (PackageFlag f) = Left f - --- TODO: Add instances and check --- --- prop_sC_idempotent cond a o = cond' == cond'' --- where --- cond' = simplifyCondition cond a o --- cond'' = simplifyCondition cond' a o --- --- prop_sC_noLits cond a o = isLit res || not (hasLits res) --- where --- res = simplifyCondition cond a o --- hasLits (Lit _) = True --- hasLits (CNot c) = hasLits c --- hasLits (COr l r) = hasLits l || hasLits r --- hasLits (CAnd l r) = hasLits l || hasLits r --- hasLits _ = False --- - --- | Parse a configuration condition from a string. -parseCondition :: CabalParsing m => m (Condition ConfVar) -parseCondition = condOr - where - condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr - condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd - -- TODO: try? - cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond - <|> archCond <|> flagCond <|> implCond ) - inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp) - notCond = P.char '!' >> sp >> cond >>= return . CNot - osCond = string "os" >> sp >> inparens osIdent >>= return . Var - archCond = string "arch" >> sp >> inparens archIdent >>= return . Var - flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var - implCond = string "impl" >> sp >> inparens implIdent >>= return . Var - boolLiteral = fmap Lit parsec - archIdent = fmap Arch parsec - osIdent = fmap OS parsec - flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar) - isIdentChar c = isAlphaNum c || c == '_' || c == '-' - oper s = sp >> string s >> sp - sp = spaces - implIdent = do i <- parsec - vr <- sp >> option anyVersion parsec - return $ Impl i vr - ------------------------------------------------------------------------------- - --- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for --- clarity. -data DepTestRslt d = DepOk | MissingDeps d - -instance Semigroup d => Monoid (DepTestRslt d) where - mempty = DepOk - mappend = (<>) - -instance Semigroup d => Semigroup (DepTestRslt d) where - DepOk <> x = x - x <> DepOk = x - (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d') - - --- | Try to find a flag assignment that satisfies the constraints of all trees. --- --- Returns either the missing dependencies, or a tuple containing the --- resulting data, the associated dependencies, and the chosen flag --- assignments. --- --- In case of failure, the union of the dependencies that led to backtracking --- on all branches is returned. --- [TODO: Could also be specified with a function argument.] --- --- TODO: The current algorithm is rather naive. A better approach would be to: --- --- * Rule out possible paths, by taking a look at the associated dependencies. --- --- * Infer the required values for the conditions of these paths, and --- calculate the required domains for the variables used in these --- conditions. Then picking a flag assignment would be linear (I guess). --- --- This would require some sort of SAT solving, though, thus it's not --- implemented unless we really need it. --- -resolveWithFlags :: - [(FlagName,[Bool])] - -- ^ Domain for each flag name, will be tested in order. - -> ComponentRequestedSpec - -> OS -- ^ OS as returned by Distribution.System.buildOS - -> Arch -- ^ Arch as returned by Distribution.System.buildArch - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> [CondTree ConfVar [Dependency] PDTagged] - -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. - -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) - -- ^ Either the missing dependencies (error case), or a pair of - -- (set of build targets with dependencies, chosen flag assignments) -resolveWithFlags dom enabled os arch impl constrs trees checkDeps = - either (Left . fromDepMapUnion) Right $ explore (build mempty dom) - where - -- simplify trees by (partially) evaluating all conditions and converting - -- dependencies to dependency maps. - simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged] - simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps - . addBuildableConditionPDTagged - . mapTreeConds (fst . simplifyWithSysParams os arch impl)) - trees - - -- @explore@ searches a tree of assignments, backtracking whenever a flag - -- introduces a dependency that cannot be satisfied. If there is no - -- solution, @explore@ returns the union of all dependencies that caused - -- it to backtrack. Since the tree is constructed lazily, we avoid some - -- computation overhead in the successful case. - explore :: Tree FlagAssignment - -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment) - explore (Node flags ts) = - let targetSet = TargetSet $ flip map simplifiedTrees $ - -- apply additional constraints to all dependencies - first (`constrainBy` constrs) . - simplifyCondTree (env flags) - deps = overallDependencies enabled targetSet - in case checkDeps (fromDepMap deps) of - DepOk | null ts -> Right (targetSet, flags) - | otherwise -> tryAll $ map explore ts - MissingDeps mds -> Left (toDepMapUnion mds) - - -- Builds a tree of all possible flag assignments. Internal nodes - -- have only partial assignments. - build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment - build assigned [] = Node assigned [] - build assigned ((fn, vals) : unassigned) = - Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals - - tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a - tryAll = foldr mp mz - - -- special version of `mplus' for our local purposes - mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a - mp m@(Right _) _ = m - mp _ m@(Right _) = m - mp (Left xs) (Left ys) = Left (xs <> ys) - - -- `mzero' - mz :: Either DepMapUnion a - mz = Left (DepMapUnion Map.empty) - - env :: FlagAssignment -> FlagName -> Either FlagName Bool - env flags flag = (maybe (Left flag) Right . lookupFlagAssignment flag) flags - --- | Transforms a 'CondTree' by putting the input under the "then" branch of a --- conditional that is True when Buildable is True. If 'addBuildableCondition' --- can determine that Buildable is always True, it returns the input unchanged. --- If Buildable is always False, it returns the empty 'CondTree'. -addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo) - -> CondTree v c a - -> CondTree v c a -addBuildableCondition getInfo t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> CondNode mempty mempty [] - c -> CondNode mempty mempty [condIfThen c t] - --- | This is a special version of 'addBuildableCondition' for the 'PDTagged' --- type. --- --- It is not simply a specialisation. It is more complicated than it --- ought to be because of the way the 'PDTagged' monoid instance works. The --- @mempty = 'PDNull'@ forgets the component type, which has the effect of --- completely deleting components that are not buildable. --- --- See for more details. --- -addBuildableConditionPDTagged :: (Eq v, Monoid c) => - CondTree v c PDTagged - -> CondTree v c PDTagged -addBuildableConditionPDTagged t = - case extractCondition (buildable . getInfo) t of - Lit True -> t - Lit False -> deleteConstraints t - c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)] - where - deleteConstraints = mapTreeConstrs (const mempty) - - getInfo :: PDTagged -> BuildInfo - getInfo (Lib l) = libBuildInfo l - getInfo (SubComp _ c) = componentBuildInfo c - getInfo PDNull = mempty - - --- Note: extracting buildable conditions. --- -------------------------------------- --- --- If the conditions in a cond tree lead to Buildable being set to False, then --- none of the dependencies for this cond tree should actually be taken into --- account. On the other hand, some of the flags may only be decided in the --- solver, so we cannot necessarily make the decision whether a component is --- Buildable or not prior to solving. --- --- What we are doing here is to partially evaluate a condition tree in order to --- extract the condition under which Buildable is True. The predicate determines --- whether data under a 'CondTree' is buildable. - --- | Extract conditions matched by the given predicate from all cond trees in a --- 'GenericPackageDescription'. -extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription - -> [Condition ConfVar] -extractConditions f gpkg = - concat [ - extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg) - , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg - , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg - , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg - , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg - ] - - --- | A map of package constraints that combines version ranges using 'unionVersionRanges'. -newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - -instance Semigroup DepMapUnion where - DepMapUnion x <> DepMapUnion y = DepMapUnion $ - Map.unionWith unionVersionRanges' x y - -unionVersionRanges' - :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs') - -toDepMapUnion :: [Dependency] -> DepMapUnion -toDepMapUnion ds = - DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - - -fromDepMapUnion :: DepMapUnion -> [Dependency] -fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ] - -freeVars :: CondTree ConfVar c a -> [FlagName] -freeVars t = [ f | PackageFlag f <- freeVars' t ] - where - freeVars' (CondNode _ _ ifs) = concatMap compfv ifs - compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct - condfv c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> condfv c' - COr c1 c2 -> condfv c1 ++ condfv c2 - CAnd c1 c2 -> condfv c1 ++ condfv c2 - - ------------------------------------------------------------------------------- - --- | A set of targets with their package dependencies -newtype TargetSet a = TargetSet [(DependencyMap, a)] - --- | Combine the target-specific dependencies in a TargetSet to give the --- dependencies for the package as a whole. -overallDependencies :: ComponentRequestedSpec -> TargetSet PDTagged -> DependencyMap -overallDependencies enabled (TargetSet targets) = mconcat depss - where - (depss, _) = unzip $ filter (removeDisabledSections . snd) targets - removeDisabledSections :: PDTagged -> Bool - -- UGH. The embedded componentName in the 'Component's here is - -- BLANK. I don't know whose fault this is but I'll use the tag - -- instead. -- ezyang - removeDisabledSections (Lib _) = componentNameRequested - enabled - (CLibName LMainLibName) - removeDisabledSections (SubComp t c) - -- Do NOT use componentName - = componentNameRequested enabled - $ case c of - CLib _ -> CLibName (LSubLibName t) - CFLib _ -> CFLibName t - CExe _ -> CExeName t - CTest _ -> CTestName t - CBench _ -> CBenchName t - removeDisabledSections PDNull = True - --- | Collect up the targets in a TargetSet of tagged targets, storing the --- dependencies as we go. -flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)]) -flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where - untag (depMap, pdTagged) accum = case (pdTagged, accum) of - (Lib _, (Just _, _)) -> userBug "Only one library expected" - (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps) - (SubComp n c, (mb_lib, comps)) - | any ((== n) . fst) comps -> - userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'" - | otherwise -> (mb_lib, (n, redoBD c) : comps) - (PDNull, x) -> x -- actually this should not happen, but let's be liberal - where - redoBD :: L.HasBuildInfo a => a -> a - redoBD = set L.targetBuildDepends $ fromDepMap depMap - ------------------------------------------------------------------------------- --- Convert GenericPackageDescription to PackageDescription --- - -data PDTagged = Lib Library - | SubComp UnqualComponentName Component - | PDNull - deriving Show - -instance Monoid PDTagged where - mempty = PDNull - mappend = (<>) - -instance Semigroup PDTagged where - PDNull <> x = x - x <> PDNull = x - Lib l <> Lib l' = Lib (l <> l') - SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') - _ <> _ = cabalBug "Cannot combine incompatible tags" - --- | Create a package description with all configurations resolved. --- --- This function takes a `GenericPackageDescription` and several environment --- parameters and tries to generate `PackageDescription` by finding a flag --- assignment that result in satisfiable dependencies. --- --- It takes as inputs a not necessarily complete specifications of flags --- assignments, an optional package index as well as platform parameters. If --- some flags are not assigned explicitly, this function will try to pick an --- assignment that causes this function to succeed. The package index is --- optional since on some platforms we cannot determine which packages have --- been installed before. When no package index is supplied, every dependency --- is assumed to be satisfiable, therefore all not explicitly assigned flags --- will get their default values. --- --- This function will fail if it cannot find a flag assignment that leads to --- satisfiable dependencies. (It will not try alternative assignments for --- explicitly specified flags.) In case of failure it will return the missing --- dependencies that it encountered when trying different flag assignments. --- On success, it will return the package description and the full flag --- assignment chosen. --- --- Note that this drops any stanzas which have @buildable: False@. While --- this is arguably the right thing to do, it means we give bad error --- messages in some situations, see #3858. --- -finalizePD :: - FlagAssignment -- ^ Explicitly specified flag assignments - -> ComponentRequestedSpec - -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of - -- available packages? If this is unknown then use - -- True. - -> Platform -- ^ The 'Arch' and 'OS' - -> CompilerInfo -- ^ Compiler information - -> [PackageVersionConstraint] -- ^ Additional constraints - -> GenericPackageDescription - -> Either [Dependency] - (PackageDescription, FlagAssignment) - -- ^ Either missing dependencies or the resolved package - -- description along with the flag assignments chosen. -finalizePD userflags enabled satisfyDep - (Platform arch os) impl constraints - (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do - (targetSet, flagVals) <- - resolveWithFlags flagChoices enabled os arch impl constraints condTrees check - let - (mb_lib, comps) = flattenTaggedTargets targetSet - mb_lib' = fmap libFillInDefaults mb_lib - comps' = flip map comps $ \(n,c) -> foldComponent - (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n - , libExposed = False }) - (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n }) - (\e -> CExe (exeFillInDefaults e) { exeName = n }) - (\t -> CTest (testFillInDefaults t) { testName = n }) - (\b -> CBench (benchFillInDefaults b) { benchmarkName = n }) - c - (sub_libs', flibs', exes', tests', bms') = partitionComponents comps' - return ( pkg { library = mb_lib' - , subLibraries = sub_libs' - , foreignLibs = flibs' - , executables = exes' - , testSuites = tests' - , benchmarks = bms' - } - , flagVals ) - where - -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data - condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0) - ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0 - ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0 - - flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags - d2c manual n b = case lookupFlagAssignment n userflags of - Just val -> [val] - Nothing - | manual -> [b] - | otherwise -> [b, not b] - --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices - check ds = let missingDeps = filter (not . satisfyDep) ds - in if null missingDeps - then DepOk - else MissingDeps missingDeps - -{- -let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) -let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) - -let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] -let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index -let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... -resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... --} - --- | Flatten a generic package description by ignoring all conditions and just --- join the field descriptors into on package description. Note, however, --- that this may lead to inconsistent field values, since all values are --- joined into one field, which may not be possible in the original package --- description, due to the use of exclusive choices (if ... else ...). --- --- TODO: One particularly tricky case is defaulting. In the original package --- description, e.g., the source directory might either be the default or a --- certain, explicitly set path. Since defaults are filled in only after the --- package has been resolved and when no explicit value has been set, the --- default path will be missing from the package description returned by this --- function. -flattenPackageDescription :: GenericPackageDescription -> PackageDescription -flattenPackageDescription - (GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) = - pkg { library = mlib - , subLibraries = reverse sub_libs - , foreignLibs = reverse flibs - , executables = reverse exes - , testSuites = reverse tests - , benchmarks = reverse bms - } - where - mlib = f <$> mlib0 - where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName } - sub_libs = flattenLib <$> sub_libs0 - flibs = flattenFLib <$> flibs0 - exes = flattenExe <$> exes0 - tests = flattenTst <$> tests0 - bms = flattenBm <$> bms0 - flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t) - { libName = LSubLibName n, libExposed = False } - flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t) - { foreignLibName = n } - flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t) - { exeName = n } - flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t) - { testName = n } - flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t) - { benchmarkName = n } - --- This is in fact rather a hack. The original version just overrode the --- default values, however, when adding conditions we had to switch to a --- modifier-based approach. There, nothing is ever overwritten, but only --- joined together. --- --- This is the cleanest way i could think of, that doesn't require --- changing all field parsing functions to return modifiers instead. -libFillInDefaults :: Library -> Library -libFillInDefaults lib@(Library { libBuildInfo = bi }) = - lib { libBuildInfo = biFillInDefaults bi } - -flibFillInDefaults :: ForeignLib -> ForeignLib -flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) = - flib { foreignLibBuildInfo = biFillInDefaults bi } - -exeFillInDefaults :: Executable -> Executable -exeFillInDefaults exe@(Executable { buildInfo = bi }) = - exe { buildInfo = biFillInDefaults bi } - -testFillInDefaults :: TestSuite -> TestSuite -testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = - tst { testBuildInfo = biFillInDefaults bi } - -benchFillInDefaults :: Benchmark -> Benchmark -benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) = - bm { benchmarkBuildInfo = biFillInDefaults bi } - -biFillInDefaults :: BuildInfo -> BuildInfo -biFillInDefaults bi = - if null (hsSourceDirs bi) - then bi { hsSourceDirs = [sameDirectory] } - else bi - --- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@ --- to all nested 'BuildInfo'/'SetupBuildInfo' values. -transformAllBuildInfos :: (BuildInfo -> BuildInfo) - -> (SetupBuildInfo -> SetupBuildInfo) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildInfos onBuildInfo onSetupBuildInfo = - over L.traverseBuildInfos onBuildInfo - . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDepends :: (Dependency -> Dependency) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDepends f = - over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f) - --- | Walk a 'GenericPackageDescription' and apply @f@ to all nested --- @build-depends@ fields. -transformAllBuildDependsN :: ([Dependency] -> [Dependency]) - -> GenericPackageDescription - -> GenericPackageDescription -transformAllBuildDependsN f = - over (L.traverseBuildInfos . L.targetBuildDepends) f - . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f - -- cannot be point-free as normal because of higher rank - . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f diff --git a/src/Distribution/PackageDescription/FieldGrammar.hs b/src/Distribution/PackageDescription/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/FieldGrammar.hs +++ /dev/null @@ -1,802 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} --- | 'GenericPackageDescription' Field descriptions -module Distribution.PackageDescription.FieldGrammar ( - -- * Package description - packageDescriptionFieldGrammar, - -- * Library - libraryFieldGrammar, - -- * Foreign library - foreignLibFieldGrammar, - -- * Executable - executableFieldGrammar, - -- * Test suite - TestSuiteStanza (..), - testSuiteFieldGrammar, - validateTestSuite, - unvalidateTestSuite, - -- ** Lenses - testStanzaTestType, - testStanzaMainIs, - testStanzaTestModule, - testStanzaBuildInfo, - -- * Benchmark - BenchmarkStanza (..), - benchmarkFieldGrammar, - validateBenchmark, - unvalidateBenchmark, - -- * Field grammars - formatDependencyList, - formatExposedModules, - formatExtraSourceFiles, - formatHsSourceDirs, - formatMixinList, - formatOtherExtensions, - formatOtherModules, - -- ** Lenses - benchmarkStanzaBenchmarkType, - benchmarkStanzaMainIs, - benchmarkStanzaBenchmarkModule, - benchmarkStanzaBuildInfo, - -- * Flag - flagFieldGrammar, - -- * Source repository - sourceRepoFieldGrammar, - -- * Setup build info - setupBInfoFieldGrammar, - -- * Component build info - buildInfoFieldGrammar, - ) where - - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Language.Haskell.Extension -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Compat.Newtype (Newtype, pack', unpack') -import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..)) -import Distribution.FieldGrammar -import Distribution.Fields -import Distribution.ModuleName (ModuleName) -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Parsec -import Distribution.Pretty (Pretty (..), prettyShow, showToken) -import Distribution.Utils.Path -import Distribution.Version (Version, VersionRange) - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.Lens as L - -------------------------------------------------------------------------------- --- PackageDescription -------------------------------------------------------------------------------- - -packageDescriptionFieldGrammar - :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier) - , c (Identity BuildType) - , c (Identity PackageName) - , c (Identity Version) - , c (List FSep FilePathNT String) - , c (List FSep CompatFilePath String) - , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile)) - , c (List FSep TestedWith (CompilerFlavor, VersionRange)) - , c (List VCat FilePathNT String) - , c FilePathNT - , c CompatLicenseFile - , c CompatFilePath - , c SpecLicense - , c SpecVersion - ) - => g PackageDescription PackageDescription -packageDescriptionFieldGrammar = PackageDescription - <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 - <*> blurFieldGrammar L.package packageIdentifierGrammar - <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) - <*> licenseFilesGrammar - <*> freeTextFieldDefST "copyright" L.copyright - <*> freeTextFieldDefST "maintainer" L.maintainer - <*> freeTextFieldDefST "author" L.author - <*> freeTextFieldDefST "stability" L.stability - <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith - <*> freeTextFieldDefST "homepage" L.homepage - <*> freeTextFieldDefST "package-url" L.pkgUrl - <*> freeTextFieldDefST "bug-reports" L.bugReports - <*> pure [] -- source-repos are stanza - <*> freeTextFieldDefST "synopsis" L.synopsis - <*> freeTextFieldDefST "description" L.description - <*> freeTextFieldDefST "category" L.category - <*> prefixedFields "x-" L.customFieldsPD - <*> optionalField "build-type" L.buildTypeRaw - <*> pure Nothing -- custom-setup - -- components - <*> pure Nothing -- lib - <*> pure [] -- sub libs - <*> pure [] -- executables - <*> pure [] -- foreign libs - <*> pure [] -- test suites - <*> pure [] -- benchmarks - -- * Files - <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles - <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "." - ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "." - <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles - <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles - <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles - where - packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName - <*> uniqueField "version" L.pkgVersion - - licenseFilesGrammar = (++) - -- TODO: neither field is deprecated - -- should we pretty print license-file if there's single license file - -- and license-files when more - <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles - <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles - ^^^ hiddenField - -------------------------------------------------------------------------------- --- Library -------------------------------------------------------------------------------- - -libraryFieldGrammar - :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo) - , c (Identity LibraryVisibility) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => LibraryName - -> g Library Library -libraryFieldGrammar n = Library n - <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules - <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules - <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures - ^^^ availableSince CabalSpecV2_0 [] - <*> booleanFieldDef "exposed" L.libExposed True - <*> visibilityField - <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar - where - visibilityField = case n of - -- nameless/"main" libraries are public - LMainLibName -> pure LibraryVisibilityPublic - -- named libraries have the field - LSubLibName _ -> - optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate - ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate - -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} - -------------------------------------------------------------------------------- --- Foreign library -------------------------------------------------------------------------------- - -foreignLibFieldGrammar - :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo) - , c (Identity ForeignLibType) - , c (Identity LibVersionInfo) - , c (Identity Version) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (Identity ForeignLibOption) ForeignLibOption) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String), c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g ForeignLib ForeignLib -foreignLibFieldGrammar n = ForeignLib n - <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown - <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions - <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar - <*> optionalField "lib-version-info" L.foreignLibVersionInfo - <*> optionalField "lib-version-linux" L.foreignLibVersionLinux - <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} - -------------------------------------------------------------------------------- --- Executable -------------------------------------------------------------------------------- - -executableFieldGrammar - :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo) - , c (Identity ExecutableScope) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => UnqualComponentName -> g Executable Executable -executableFieldGrammar n = Executable n - -- main-is is optional as conditional blocks don't have it - <$> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" - <*> optionalFieldDef "scope" L.exeScope ExecutablePublic - ^^^ availableSince CabalSpecV2_0 ExecutablePublic - <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} -{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} - -------------------------------------------------------------------------------- --- TestSuite -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the test-suite stanza. --- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza - { _testStanzaTestType :: Maybe TestType - , _testStanzaMainIs :: Maybe FilePath - , _testStanzaTestModule :: Maybe ModuleName - , _testStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo TestSuiteStanza where - buildInfo = testStanzaBuildInfo - -testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) -testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) -{-# INLINE testStanzaTestType #-} - -testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath) -testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s)) -{-# INLINE testStanzaMainIs #-} - -testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) -testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s)) -{-# INLINE testStanzaTestModule #-} - -testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo -testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s)) -{-# INLINE testStanzaBuildInfo #-} - -testSuiteFieldGrammar - :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo) - , c (Identity ModuleName) - , c (Identity TestType) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g TestSuiteStanza TestSuiteStanza -testSuiteFieldGrammar = TestSuiteStanza - <$> optionalField "type" testStanzaTestType - <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs - <*> optionalField "test-module" testStanzaTestModule - <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar - -validateTestSuite :: Position -> TestSuiteStanza -> ParseResult TestSuite -validateTestSuite pos stanza = case _testStanzaTestType stanza of - Nothing -> return $ - emptyTestSuite { testBuildInfo = _testStanzaBuildInfo stanza } - - Just tt@(TestTypeUnknown _ _) -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownTestTypes -> - pure emptyTestSuite - { testInterface = TestSuiteUnsupported tt - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyTestSuite - Just file -> do - when (isJust (_testStanzaTestModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt) - pure emptyTestSuite - { testInterface = TestSuiteExeV10 ver file - , testBuildInfo = _testStanzaBuildInfo stanza - } - - Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of - Nothing -> do - parseFailure pos (missingField "test-module" tt) - pure emptyTestSuite - Just module_ -> do - when (isJust (_testStanzaMainIs stanza)) $ - parseWarning pos PWTExtraMainIs (extraField "main-is" tt) - pure emptyTestSuite - { testInterface = TestSuiteLibV09 ver module_ - , testBuildInfo = _testStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " test suite type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' test suite type." - -unvalidateTestSuite :: TestSuite -> TestSuiteStanza -unvalidateTestSuite t = TestSuiteStanza - { _testStanzaTestType = ty - , _testStanzaMainIs = ma - , _testStanzaTestModule = mo - , _testStanzaBuildInfo = testBuildInfo t - } - where - (ty, ma, mo) = case testInterface t of - TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing) - TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Benchmark -------------------------------------------------------------------------------- - --- | An intermediate type just used for parsing the benchmark stanza. --- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza - { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType - , _benchmarkStanzaMainIs :: Maybe FilePath - , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , _benchmarkStanzaBuildInfo :: BuildInfo - } - -instance L.HasBuildInfo BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo - -benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) -benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) -{-# INLINE benchmarkStanzaBenchmarkType #-} - -benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath) -benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s)) -{-# INLINE benchmarkStanzaMainIs #-} - -benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) -benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s)) -{-# INLINE benchmarkStanzaBenchmarkModule #-} - -benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo -benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s)) -{-# INLINE benchmarkStanzaBuildInfo #-} - -benchmarkFieldGrammar - :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo) - , c (Identity BenchmarkType) - , c (Identity ModuleName) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BenchmarkStanza BenchmarkStanza -benchmarkFieldGrammar = BenchmarkStanza - <$> optionalField "type" benchmarkStanzaBenchmarkType - <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs - <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule - <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar - -validateBenchmark :: Position -> BenchmarkStanza -> ParseResult Benchmark -validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of - Nothing -> pure emptyBenchmark - { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza } - - Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark - { benchmarkInterface = BenchmarkUnsupported tt - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of - Nothing -> do - parseFailure pos (missingField "main-is" tt) - pure emptyBenchmark - Just file -> do - when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $ - parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt) - pure emptyBenchmark - { benchmarkInterface = BenchmarkExeV10 ver file - , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza - } - - where - missingField name tt = "The '" ++ name ++ "' field is required for the " - ++ prettyShow tt ++ " benchmark type." - - extraField name tt = "The '" ++ name ++ "' field is not used for the '" - ++ prettyShow tt ++ "' benchmark type." - -unvalidateBenchmark :: Benchmark -> BenchmarkStanza -unvalidateBenchmark b = BenchmarkStanza - { _benchmarkStanzaBenchmarkType = ty - , _benchmarkStanzaMainIs = ma - , _benchmarkStanzaBenchmarkModule = mo - , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b - } - where - (ty, ma, mo) = case benchmarkInterface b of - BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing) - BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing) - _ -> (Nothing, Nothing, Nothing) - -------------------------------------------------------------------------------- --- Build info -------------------------------------------------------------------------------- - -buildInfoFieldGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List CommaFSep (Identity ExeDependency) ExeDependency) - , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) - , c (List CommaVCat (Identity Mixin) Mixin) - , c (List FSep (MQuoted Extension) Extension) - , c (List FSep (MQuoted Language) Language) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (List NoCommaFSep Token' String) - , c (List VCat (MQuoted ModuleName) ModuleName) - , c (List VCat FilePathNT String) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - , c (List VCat Token String) - , c (MQuoted Language) - ) - => g BuildInfo BuildInfo -buildInfoFieldGrammar = BuildInfo - <$> booleanFieldDef "buildable" L.buildable True - <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools - ^^^ deprecatedSince CabalSpecV2_0 - "Please use 'build-tool-depends' field" - ^^^ removedIn CabalSpecV3_0 - "Please use 'build-tool-depends' field." - <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends - -- {- ^^^ availableSince [2,0] [] -} - -- here, we explicitly want to recognise build-tool-depends for all Cabal files - -- as otherwise cabal new-build cannot really work. - -- - -- I.e. we don't want trigger unknown field warning - <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions - <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions - <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions - <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions - ^^^ availableSince CabalSpecV3_6 [] - <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends - <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs - <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources - <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources - <*> hsSourceDirsGrammar - <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules - <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules - ^^^ availableSince CabalSpecV2_2 [] - <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules - ^^^ availableSince CabalSpecV2_0 [] - <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage - ^^^ availableSince CabalSpecV1_10 Nothing - <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions - ^^^ availableSince CabalSpecV1_10 [] - <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions - ^^^ availableSinceWarn CabalSpecV1_10 - <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions - ^^^ deprecatedSince CabalSpecV1_12 - "Please use 'default-extensions' or 'other-extensions' fields." - ^^^ removedIn CabalSpecV3_0 - "Please use 'default-extensions' or 'other-extensions' fields." - <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs - <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs - <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs - <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours - <*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs - <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes - ^^^ availableSince CabalSpecV3_0 [] - <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes - <*> optionsFieldGrammar - <*> profOptionsFieldGrammar - <*> sharedOptionsFieldGrammar - <*> pure mempty -- static-options ??? - <*> prefixedFields "x-" L.customFieldsBI - <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends - <*> monoidalFieldAla "mixins" formatMixinList L.mixins - ^^^ availableSince CabalSpecV2_0 [] -{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} -{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} - -hsSourceDirsGrammar - :: ( FieldGrammar c g, Applicative (g BuildInfo) - , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir)) - ) - => g BuildInfo [SymbolicPath PackageDir SourceDir] -hsSourceDirsGrammar = (++) - <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens - --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 - ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" - ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." - where - -- TODO: make pretty printer aware of CabalSpecVersion - wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir] - wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] - -optionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -optionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS) - -- NOTE: Hugs, NHC and JHC are not supported anymore, but these - -- fields are kept around so that we can still parse legacy .cabal - -- files that have them. - <* knownField "jhc-options" - <* knownField "hugs-options" - <* knownField "nhc98-options" - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.options . lookupLens flavor - -profOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -profOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profOptions . lookupLens flavor - -sharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) -sharedOptionsFieldGrammar = PerCompilerFlavor - <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) - <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) - where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.sharedOptions . lookupLens flavor - -lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v -lookupLens k f p@(PerCompilerFlavor ghc ghcjs) - | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc - | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs - | otherwise = p <$ f mempty - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagFieldGrammar - :: (FieldGrammar c g, Applicative (g PackageFlag)) - => FlagName -> g PackageFlag PackageFlag -flagFieldGrammar name = MkPackageFlag name - <$> freeTextFieldDef "description" L.flagDescription - <*> booleanFieldDef "default" L.flagDefault True - <*> booleanFieldDef "manual" L.flagManual False -{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} -{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} - -------------------------------------------------------------------------------- --- SourceRepo -------------------------------------------------------------------------------- - -sourceRepoFieldGrammar - :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) - => RepoKind -> g SourceRepo SourceRepo -sourceRepoFieldGrammar kind = SourceRepo kind - <$> optionalField "type" L.repoType - <*> freeTextField "location" L.repoLocation - <*> optionalFieldAla "module" Token L.repoModule - <*> optionalFieldAla "branch" Token L.repoBranch - <*> optionalFieldAla "tag" Token L.repoTag - <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} - -------------------------------------------------------------------------------- --- SetupBuildInfo -------------------------------------------------------------------------------- - -setupBInfoFieldGrammar - :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) - => Bool -> g SetupBuildInfo SetupBuildInfo -setupBInfoFieldGrammar def = flip SetupBuildInfo def - <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} - -------------------------------------------------------------------------------- --- Define how field values should be formatted for 'pretty'. -------------------------------------------------------------------------------- - -formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency -formatDependencyList = alaList CommaVCat - -formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin -formatMixinList = alaList CommaVCat - -formatExtraSourceFiles :: [FilePath] -> List VCat FilePathNT FilePath -formatExtraSourceFiles = alaList' VCat FilePathNT - -formatExposedModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatExposedModules = alaList' VCat MQuoted - -formatHsSourceDirs :: [SymbolicPath PackageDir SourceDir] -> List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir) -formatHsSourceDirs = alaList FSep - -formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension -formatOtherExtensions = alaList' FSep MQuoted - -formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatOtherModules = alaList' VCat MQuoted - -------------------------------------------------------------------------------- --- newtypes -------------------------------------------------------------------------------- - --- | Compat FilePath accepts empty file path, --- but issues a warning. --- --- There are simply too many (~1200) package definition files --- --- @ --- license-file: "" --- @ --- --- and --- --- @ --- data-dir: "" --- @ --- --- across Hackage to outrule them completely. --- I suspect some of them are generated (e.g. formatted) by machine. --- -newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath - -instance Newtype String CompatFilePath - -instance Parsec CompatFilePath where - parsec = do - token <- parsecToken - if null token - then do - parsecWarning PWTEmptyFilePath "empty FilePath" - return (CompatFilePath "") - else return (CompatFilePath token) - -instance Pretty CompatFilePath where - pretty = showToken . getCompatFilePath - -newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] } - -instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile - --- TODO -instance Parsec CompatLicenseFile where - parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec - where - emptyToken = P.try $ do - token <- parsecToken - if null token - then return (CompatLicenseFile []) - else P.unexpected "non-empty-token" - -instance Pretty CompatLicenseFile where - pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile - -------------------------------------------------------------------------------- --- vim syntax definitions -------------------------------------------------------------------------------- - --- | '_syntaxFieldNames' and '_syntaxExtensions' --- are for generating VIM syntax file definitions. --- -_syntaxFieldNames :: IO () -_syntaxFieldNames = sequence_ - [ BS8.putStrLn $ " \\ " <> n - | n <- nub $ sort $ mconcat - [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar - , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName - , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" - , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" - , fieldGrammarKnownFieldList testSuiteFieldGrammar - , fieldGrammarKnownFieldList benchmarkFieldGrammar - , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") - , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") - , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True - ] - ] - -_syntaxExtensions :: IO () -_syntaxExtensions = sequence_ - [ putStrLn $ " \\ " <> e - | e <- ["Safe","Trustworthy","Unsafe"] - ++ es - ++ map ("No"++) es - ] - where - es = nub $ sort - [ prettyShow e - | e <- [ minBound .. maxBound ] - , e `notElem` [Safe,Unsafe,Trustworthy] - ] diff --git a/src/Distribution/PackageDescription/Parsec.hs b/src/Distribution/PackageDescription/Parsec.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Parsec.hs +++ /dev/null @@ -1,980 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.Parsec --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defined parsers and partial pretty printers for the @.cabal@ format. - -module Distribution.PackageDescription.Parsec ( - -- * Package descriptions - readGenericPackageDescription, - parseGenericPackageDescription, - parseGenericPackageDescriptionMaybe, - - -- ** Parsing - ParseResult, - runParseResult, - - -- * New-style spec-version - scanSpecVersion, - - -- ** Supplementary build information - readHookedBuildInfo, - parseHookedBuildInfo, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Control.Monad.State.Strict (StateT, execStateT) -import Control.Monad.Trans.Class (lift) -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens -import Distribution.FieldGrammar -import Distribution.FieldGrammar.Parsec (NamelessField (..)) -import Distribution.Fields.ConfVar (parseConditionConfVar) -import Distribution.Fields.Field (FieldName, getName) -import Distribution.Fields.LexerMonad (LexWarning, toPWarnings) -import Distribution.Fields.Parser -import Distribution.Fields.ParseResult -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar -import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) -import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) -import Distribution.Parsec.Position (Position (..), zeroPos) -import Distribution.Parsec.Warning (PWarnType (..)) -import Distribution.Pretty (prettyShow) -import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) -import Distribution.Utils.Generic (breakMaybe, unfoldrM, validateUTF8) -import Distribution.Verbosity (Verbosity) -import Distribution.Version (Version, mkVersion, versionNumbers) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.Newtype as Newtype -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.Executable.Lens as L -import qualified Distribution.Types.ForeignLib.Lens as L -import qualified Distribution.Types.GenericPackageDescription.Lens as L -import qualified Distribution.Types.PackageDescription.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L -import qualified Text.Parsec as P - --- --------------------------------------------------------------- --- Parsing --- --------------------------------------------------------------- - --- | Parse the given package file. -readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription -readGenericPackageDescription = readAndParseFile parseGenericPackageDescription - ------------------------------------------------------------------------------- --- | Parses the given file into a 'GenericPackageDescription'. --- --- In Cabal 1.2 the syntax for package descriptions was changed to a format --- with sections and possibly indented property descriptions. --- -parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription -parseGenericPackageDescription bs = do - -- set scanned version - setCabalSpecVersion ver - - csv <- case ver of - -- if we get too new version, fail right away - Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of - Just csv -> return (Just csv) - Nothing -> parseFatalFailure zeroPos $ - "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899." - _ -> pure Nothing - - case readFields' bs'' of - Right (fs, lexWarnings) -> do - when patched $ - parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" - -- UTF8 is validated in a prepass step, afterwards parsing is lenient. - parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure pos (show perr) where - ppos = P.errorPos perr - pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) - where - (patched, bs') = patchQuirks bs - ver = scanSpecVersion bs' - - invalidUtf8 = validateUTF8 bs' - - -- if there are invalid utf8 characters, we make the bytestring valid. - bs'' = case invalidUtf8 of - Nothing -> bs' - Just _ -> toUTF8BS (fromUTF8BS bs') - - --- | 'Maybe' variant of 'parseGenericPackageDescription' -parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription -parseGenericPackageDescriptionMaybe = - either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription - -fieldlinesToBS :: [FieldLine ann] -> BS.ByteString -fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) - --- Monad in which sections are parsed -type SectionParser = StateT SectionS ParseResult - --- | State of section parser -data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) - } - -stateGpd :: Lens' SectionS GenericPackageDescription -stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd -{-# INLINE stateGpd #-} - -stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) -stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -{-# INLINE stateCommonStanzas #-} - --- Note [Accumulating parser] --- --- This parser has two "states": --- * first we parse fields of PackageDescription --- * then we parse sections (libraries, executables, etc) -parseGenericPackageDescription' - :: Maybe CabalSpecVersion - -> [LexWarning] - -> Maybe Int - -> [Field Position] - -> ParseResult GenericPackageDescription -parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do - parseWarnings (toPWarnings lexWarnings) - for_ utf8WarnPos $ \pos -> - parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos - let (syntax, fs') = sectionizeFields fs - let (fields, sectionFields) = takeFields fs' - - -- cabal-version - specVer <- case scannedVer of - Just v -> return v - Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of - Nothing -> return CabalSpecV1_0 - Just (MkNamelessField pos fls) -> do - -- version will be parsed twice, therefore we parse without warnings. - v <- withoutWarnings $ - Newtype.unpack' SpecVersion <$> - -- Use version with || and && but before addition of ^>= and removal of -any - runFieldParser pos parsec CabalSpecV1_24 fls - - -- if it were at the beginning, scanner would found it - when (v >= CabalSpecV2_2) $ parseFailure pos $ - "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++ - "See https://github.com/haskell/cabal/issues/4899" - - return v - - -- reset cabal version, it might not be set - let specVer' = mkVersion (cabalSpecToVersionDigits specVer) - setCabalSpecVersion (Just specVer') - - -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar - - -- Check that scanned and parsed versions match. - unless (specVer == specVersion pd) $ parseFailure zeroPos $ - "Scanned and parsed cabal-versions don't match " ++ - prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd)) - - maybeWarnCabalVersion syntax pd - - -- Sections - let gpd = emptyGenericPackageDescription - & L.packageDescription .~ pd - gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 - -- See nothunks test, without this deepseq we get (at least): - -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} - -- - -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) - -- TODO: remove the need for deepseq if `deepseq` in fact matters - -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure - gpd2 `deepseq` return gpd2 - where - safeLast :: [a] -> Maybe a - safeLast = listToMaybe . reverse - - newSyntaxVersion :: CabalSpecVersion - newSyntaxVersion = CabalSpecV1_2 - - maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult () - maybeWarnCabalVersion syntax pkg - | syntax == NewSyntax && specVersion pkg < newSyntaxVersion - = parseWarning zeroPos PWTNewSyntax $ - "A package using section syntax must specify at least\n" - ++ "'cabal-version: >= 1.2'." - - maybeWarnCabalVersion syntax pkg - | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion - = parseWarning zeroPos PWTOldSyntax $ - "A package using 'cabal-version: " - ++ prettyShow (SpecVersion (specVersion pkg)) - ++ "' must use section syntax. See the Cabal user guide for details." - - maybeWarnCabalVersion _ _ = return () - -goSections :: CabalSpecVersion -> [Field Position] -> SectionParser () -goSections specVer = traverse_ process - where - process (Field (Name pos name) _) = - lift $ parseWarning pos PWTTrailingFields $ - "Ignoring trailing fields after sections: " ++ show name - process (Section name args secFields) = - parseSection name args secFields - - snoc x xs = xs ++ [x] - - hasCommonStanzas = specHasCommonStanzas specVer - - -- we need signature, because this is polymorphic, but not-closed - parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) - parseCondTree' = parseCondTreeWithCommonStanzas specVer - - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () - parseSection (Name pos name) args fields - | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do - parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." - - | name == "common" = do - commonStanzas <- use stateCommonStanzas - name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields - - case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas - Just _ -> lift $ parseFailure pos $ - "Duplicate common stanza: " ++ name' - - | name == "library" && null args = do - prev <- use $ stateGpd . L.condLibrary - when (isJust prev) $ lift $ parseFailure pos $ - "Multiple main libraries; have you forgotten to specify a name for an internal library?" - - commonStanzas <- use stateCommonStanzas - let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- - -- TODO check that not set - stateGpd . L.condLibrary ?= lib - - -- Sublibraries - -- TODO: check cabal-version - | name == "library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condSubLibraries %= snoc (name', lib) - - -- TODO: check cabal-version - | name == "foreign-library" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - - let hasType ts = foreignLibType ts /= foreignLibType mempty - unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat - [ "Foreign library " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownForeignLibTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condForeignLibs %= snoc (name', flib) - - | name == "executable" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - -- TODO check duplicate name here? - stateGpd . L.condExecutables %= snoc (name', exe) - - | name == "test-suite" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite pos) testStanza - - let hasType ts = testInterface ts /= testInterface mempty - unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat - [ "Test suite " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownTestTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condTestSuites %= snoc (name', testSuite) - - | name == "benchmark" = do - commonStanzas <- use stateCommonStanzas - name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields - bench <- lift $ traverse (validateBenchmark pos) benchStanza - - let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty - unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat - [ "Benchmark " ++ show (prettyShow name') - , " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available benchmark types are: " - , intercalate ", " (map prettyShow knownBenchmarkTypes) - ] - - -- TODO check duplicate name here? - stateGpd . L.condBenchmarks %= snoc (name', bench) - - | name == "flag" = do - name' <- parseNameBS pos args - name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName "" - flag <- lift $ parseFields specVer fields (flagFieldGrammar name'') - -- Check default flag - stateGpd . L.genPackageFlags %= snoc flag - - | name == "custom-setup" && null args = do - sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) - stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi - - | name == "source-repository" = do - kind <- lift $ case args of - [SecArgName spos secName] -> - runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead - [] -> do - parseFailure pos "'source-repository' requires exactly one argument" - pure RepoHead - _ -> do - parseFailure pos $ "Invalid source-repository kind " ++ show args - pure RepoHead - - sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind) - stateGpd . L.packageDescription . L.sourceRepos %= snoc sr - - | otherwise = lift $ - parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name - -parseName :: Position -> [SectionArg Position] -> SectionParser String -parseName pos args = fromUTF8BS <$> parseNameBS pos args - -parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString --- TODO: use strict parser -parseNameBS pos args = case args of - [SecArgName _pos secName] -> - pure secName - [SecArgStr _pos secName] -> - pure secName - [] -> do - lift $ parseFailure pos "name required" - pure "" - _ -> do - -- TODO: pretty print args - lift $ parseFailure pos $ "Invalid name " ++ show args - pure "" - -parseCommonName :: Position -> [SectionArg Position] -> ParseResult String -parseCommonName pos args = case args of - [SecArgName _pos secName] -> - pure $ fromUTF8BS secName - [SecArgStr _pos secName] -> - pure $ fromUTF8BS secName - [] -> do - parseFailure pos $ "name required" - pure "" - _ -> do - -- TODO: pretty print args - parseFailure pos $ "Invalid name " ++ show args - pure "" - --- TODO: avoid conversion to 'String'. -parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName -parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args - --- | Parse a non-recursive list of fields. -parseFields - :: CabalSpecVersion - -> [Field Position] -- ^ fields to be parsed - -> ParsecFieldGrammar' a - -> ParseResult a -parseFields v fields grammar = do - let (fs0, ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - parseFieldGrammar v fs0 grammar - -warnInvalidSubsection :: Section Position -> ParseResult () -warnInvalidSubsection (MkSection (Name pos name) _ _) = - void $ parseFailure pos $ "invalid subsection " ++ show name - -parseCondTree - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> HasElif -- ^ accept @elif@ - -> ParsecFieldGrammar' a -- ^ grammar - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> (BuildInfo -> a) -- ^ constructor from buildInfo - -> (a -> [Dependency]) -- ^ condition extractor - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go - where - go fields0 = do - (fields, endo) <- - if v >= CabalSpecV3_0 - then processImports v fromBuildInfo commonStanzas fields0 - else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) - - let (fs, ss) = partitionFields fields - x <- parseFieldGrammar v fs grammar - branches <- concat <$> traverse parseIfs ss - return $ endo $ CondNode x (cond x) branches - - parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a] - parseIfs [] = return [] - parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - return (CondBranch test' fields' elseFields : sections') - parseIfs (MkSection (Name pos name) _ _ : sections) = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name - parseIfs sections - - parseElseIfs - :: [Section Position] - -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a]) - parseElseIfs [] = return (Nothing, []) - parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do - unless (null args) $ - parseFailure pos $ "`else` section has section arguments " ++ show args - elseFields <- go fields - sections' <- parseIfs sections - return (Just elseFields, sections') - - parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do - test' <- parseConditionConfVar test - fields' <- go fields - (elseFields, sections') <- parseElseIfs sections - -- we parse an empty 'Fields', to get empty value for a node - a <- parseFieldGrammar v mempty grammar - return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') - - parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do - parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." - (,) Nothing <$> parseIfs sections - - parseElseIfs sections = (,) Nothing <$> parseIfs sections - -{- Note [Accumulating parser] - -Note: Outdated a bit - -In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a -> -FieldParser a)@. The weird value is used because we accumulate structure of -@a@ by folding over the fields. There are various reasons for that: - -* Almost all fields are optional - -* This is simple approach so declarative bi-directional format (parsing and -printing) of structure could be specified (list of @'FieldDescr' a@) - -* There are surface syntax fields corresponding to single field in the file: - @license-file@ and @license-files@ - -* This is quite safe approach. - -When/if we re-implement the parser to support formatting preservging roundtrip -with new AST, this all need to be rewritten. --} - -------------------------------------------------------------------------------- --- Common stanzas -------------------------------------------------------------------------------- - --- $commonStanzas --- --- [Note: Common stanzas] --- --- In Cabal 2.2 we support simple common stanzas: --- --- * Commons stanzas define 'BuildInfo' --- --- * import "fields" can only occur at top of other stanzas (think: imports) --- --- In particular __there aren't__ --- --- * implicit stanzas --- --- * More specific common stanzas (executable, test-suite). --- --- --- The approach uses the fact that 'BuildInfo' is a 'Monoid': --- --- @ --- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp --- mergeCommonStanza' bi = over L.BuildInfo (bi <>) --- @ --- --- Real 'mergeCommonStanza' is more complicated as we have to deal with --- conditional trees. --- --- The approach is simple, and have good properties: --- --- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. --- -type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo - --- | Create @a@ from 'BuildInfo'. --- This class is used to implement common stanza parsing. --- --- Law: @view buildInfo . fromBuildInfo = id@ --- --- This takes name, as 'FieldGrammar's take names too. -class L.HasBuildInfo a => FromBuildInfo a where - fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a - -libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library -libraryFromBuildInfo n bi = emptyLibrary - { libName = n - , libVisibility = case n of - LMainLibName -> LibraryVisibilityPublic - LSubLibName _ -> LibraryVisibilityPrivate - , libBuildInfo = bi - } - -instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id -instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib -instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable - -instance FromBuildInfo TestSuiteStanza where - fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi - -instance FromBuildInfo BenchmarkStanza where - fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi - -parseCondTreeWithCommonStanzas - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> ParsecFieldGrammar' a -- ^ grammar - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult (CondTree ConfVar [Dependency] a) -parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do - (fields', endo) <- processImports v fromBuildInfo commonStanzas fields - x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields' - return (endo x) - where - hasElif = specHasElif v - -processImports - :: forall a. L.HasBuildInfo a - => CabalSpecVersion - -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo -- ^ common stanzas - -> [Field Position] - -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a) -processImports v fromBuildInfo commonStanzas = go [] - where - hasCommonStanzas = specHasCommonStanzas v - - getList' :: List CommaFSep Token String -> [String] - getList' = Newtype.unpack - - go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do - parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - go acc fields - -- supported: - go acc (Field (Name pos name) fls : fields) | name == "import" = do - names <- getList' <$> runFieldParser pos parsec v fls - names' <- for names $ \commonName -> - case Map.lookup commonName commonStanzas of - Nothing -> do - parseFailure pos $ "Undefined common stanza imported: " ++ commonName - pure Nothing - Just commonTree -> - pure (Just commonTree) - - go (acc ++ catMaybes names') fields - - -- parse actual CondTree - go acc fields = do - fields' <- catMaybes <$> traverse (warnImport v) fields - pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc) - --- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered -warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position)) -warnImport v (Field (Name pos name) _) | name == "import" = do - if specHasCommonStanzas v == NoCommonStanzas - then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" - else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section" - return Nothing -warnImport _ f = pure (Just f) - -mergeCommonStanza - :: L.HasBuildInfo a - => (BuildInfo -> a) - -> CondTree ConfVar [Dependency] BuildInfo - -> CondTree ConfVar [Dependency] a - -> CondTree ConfVar [Dependency] a -mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) = - CondNode x' (x' ^. L.targetBuildDepends) cs' - where - -- new value is old value with buildInfo field _prepended_. - x' = x & L.buildInfo %~ (bi <>) - - -- tree components are appended together. - cs' = map (fmap fromBuildInfo) bis ++ cs - -------------------------------------------------------------------------------- --- Branches -------------------------------------------------------------------------------- - --- Check that a property holds on all branches of a condition tree -onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool -onAllBranches p = go mempty - where - -- If the current level of the tree satisfies the property, then we are - -- done. If not, then one of the conditional branches below the current node - -- must satisfy it. Each node may have multiple immediate children; we only - -- one need one to satisfy the property because the configure step uses - -- 'mappend' to join together the results of flag resolution. - go :: a -> CondTree v c a -> Bool - go acc ct = let acc' = acc `mappend` condTreeData ct - in p acc' || any (goBranch acc') (condTreeComponents ct) - - -- Both the 'true' and the 'false' block must satisfy the property. - goBranch :: a -> CondBranch v c a -> Bool - goBranch _ (CondBranch _ _ Nothing) = False - goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e - -------------------------------------------------------------------------------- --- Post parsing checks -------------------------------------------------------------------------------- - --- | Check that we --- --- * don't use undefined flags (very bad) --- * define flags which are unused (just bad) --- -checkForUndefinedFlags :: GenericPackageDescription -> ParseResult () -checkForUndefinedFlags gpd = do - let definedFlags, usedFlags :: Set.Set FlagName - definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd - usedFlags = getConst $ L.allCondTrees f gpd - - -- Note: we can check for defined, but unused flags here too. - unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $ - "These flags are used without having been defined: " ++ - intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ] - where - f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a) - f ct = Const (Set.fromList (freeVars ct)) - --- | Since @cabal-version: 1.24@ one can specify @custom-setup@. --- Let us require it. --- -checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult () -checkForUndefinedCustomSetup gpd = do - let pd = packageDescription gpd - let csv = specVersion pd - - when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $ - when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $ - "Since cabal-version: 1.24 specifying custom-setup section is mandatory" - -------------------------------------------------------------------------------- --- Post processing of internal dependencies -------------------------------------------------------------------------------- - --- Note [Dependencies on sublibraries] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- --- This is solution to https://github.com/haskell/cabal/issues/6083 --- --- Before 'cabal-version: 3.0' we didn't have a syntax specially --- for referring to internal libraries. Internal library names --- shadowed the outside ones. --- --- Since 'cabal-version: 3.0' we have ability to write --- --- build-depends: some-package:its-sub-lib >=1.2.3 --- --- This allows us to refer also to local packages by `this-package:sublib`. --- So since 'cabal-version: 3.4' to refer to *any* --- sublibrary we must use the two part syntax. Here's small table: --- --- | pre-3.4 | 3.4 and after | --- ------------------|---------------------|-------------------------------| --- pkg-name | may refer to sublib | always refers to external pkg | --- pkg-name:sublib | refers to sublib | refers to sublib | --- pkg-name:pkg-name | may refer to sublib | always refers to external pkg | --- --- In pre-3.4 case, if a package 'this-pkg' has a sublibrary 'pkg-name', --- all dependency definitions will refer to that sublirary. --- --- In 3.4 and after case, 'pkg-name' will always refer to external package, --- and to use internal library you have to say 'this-pkg:pkg-name'. --- --- In summary, In 3.4 and after, the internal names don't shadow, --- as there is an explicit syntax to refer to them, --- i.e. what you write is what you get; --- For pre-3.4 we post-process the file. --- --- Similarly, we process mixins. --- See https://github.com/haskell/cabal/issues/6281 --- - -postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -postProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | uqn `Set.member` internalLibs - , LMainLibName `NES.member` ln - = case NES.delete LMainLibName ln of - Nothing -> [dep] - Just ln' -> [dep, Dependency pn vr ln'] - where - uqn = packageNameToUnqualComponentName pn - dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn)) - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn LMainLibName incl) - | uqn `Set.member` internalLibs - = mkMixin thisPn (LSubLibName uqn) incl - where - uqn = packageNameToUnqualComponentName pn - - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - - internalLibs :: Set UnqualComponentName - internalLibs = Set.fromList - [ n - | (n, _) <- condSubLibraries gpd - ] - -------------------------------------------------------------------------------- --- Old syntax -------------------------------------------------------------------------------- - --- TODO: move to own module - --- | "Sectionize" an old-style Cabal file. A sectionized file has: --- --- * all global fields at the beginning, followed by --- --- * all flag declarations, followed by --- --- * an optional library section, and an arbitrary number of executable --- sections (in any order). --- --- The current implementation just gathers all library-specific fields --- in a library section and wraps all executable stanzas in an executable --- section. -sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) -sectionizeFields fs = case classifyFields fs of - Just fields -> (OldSyntax, convert fields) - Nothing -> (NewSyntax, fs) - where - -- return 'Just' if all fields are simple fields - classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])] - classifyFields = traverse f - where - f (Field name fieldlines) = Just (name, fieldlines) - f _ = Nothing - - trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse - isSpace' = (== 32) - - convert :: [(Name ann, [FieldLine ann])] -> [Field ann] - convert fields = - let - toField (name, ls) = Field name ls - -- "build-depends" is a local field now. To be backwards - -- compatible, we still allow it as a global field in old-style - -- package description files and translate it to a local field by - -- adding it to every non-empty section - (hdr0, exes0) = break ((=="executable") . getName . fst) fields - (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 - - (deps, libfs) = partition ((== "build-depends") . getName . fst) - libfs0 - - exes = unfoldr toExe exes0 - toExe [] = Nothing - toExe ((Name pos n, ls) : r) - | n == "executable" = - let (efs, r') = break ((== "executable") . getName . fst) r - in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r') - toExe _ = error "unexpected input to 'toExe'" - - lib = case libfs of - [] -> [] - ((Name pos _, _) : _) -> - [Section (Name pos "library") [] (map toField $ deps ++ libfs)] - - in map toField hdr ++ lib ++ exes - --- | See 'sectionizeFields'. -data Syntax = OldSyntax | NewSyntax - deriving (Eq, Show) - --- TODO: -libFieldNames :: [FieldName] -libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) - -------------------------------------------------------------------------------- --- Suplementary build information -------------------------------------------------------------------------------- - -readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -readHookedBuildInfo = readAndParseFile parseHookedBuildInfo - -parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo -parseHookedBuildInfo bs = case readFields' bs of - Right (fs, lexWarnings) -> do - parseHookedBuildInfo' lexWarnings fs - -- TODO: better marshalling of errors - Left perr -> parseFatalFailure zeroPos (show perr) - -parseHookedBuildInfo' - :: [LexWarning] - -> [Field Position] - -> ParseResult HookedBuildInfo -parseHookedBuildInfo' lexWarnings fs = do - parseWarnings (toPWarnings lexWarnings) - (mLibFields, exes) <- stanzas fs - mLib <- parseLib mLibFields - biExes <- traverse parseExe exes - return (mLib, biExes) - where - parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) - parseLib fields - | Map.null fields = pure Nothing - | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - - parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo) - parseExe (n, fields) = do - bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar - pure (n, bi) - - stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)]) - stanzas fields = do - let (hdr0, exes0) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - exes <- unfoldrM (traverse toExe) exes0 - pure (hdr, exes) - - toFields :: [Field Position] -> ParseResult (Fields Position) - toFields fields = do - let (fields', ss) = partitionFields fields - traverse_ (traverse_ warnInvalidSubsection) ss - pure fields' - - toExe - :: ([FieldLine Position], [Field Position]) - -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position])) - toExe (fss, fields) = do - name <- runFieldParser zeroPos parsec cabalSpecLatest fss - let (hdr0, rest) = breakMaybe isExecutableField fields - hdr <- toFields hdr0 - pure ((name, hdr), rest) - - isExecutableField (Field (Name _ name) fss) - | name == "executable" = Just fss - | otherwise = Nothing - isExecutableField _ = Nothing - -------------------------------------------------------------------------------- --- Scan of spec version -------------------------------------------------------------------------------- - --- | Quickly scan new-style spec-version --- --- A new-style spec-version declaration begins the .cabal file and --- follow the following case-insensitive grammar (expressed in --- RFC5234 ABNF): --- --- @ --- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS --- --- spec-version = NUM "." NUM [ "." NUM ] --- --- NUM = DIGIT0 / DIGITP 1*DIGIT0 --- DIGIT0 = %x30-39 --- DIGITP = %x31-39 --- WS = %20 --- @ --- -scanSpecVersion :: BS.ByteString -> Maybe Version -scanSpecVersion bs = do - fstline':_ <- pure (BS8.lines bs) - - -- parse - -- normalise: remove all whitespace, convert to lower-case - let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline' - ["cabal-version",vers] <- pure (BS8.split ':' fstline) - - -- parse - -- - -- This is currently more tolerant regarding leading 0 digits. - -- - ver <- simpleParsecBS vers - guard $ case versionNumbers ver of - [_,_] -> True - [_,_,_] -> True - _ -> False - - pure ver - where - -- | Translate ['A'..'Z'] to ['a'..'z'] - toLowerW8 :: Word8 -> Word8 - toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 - | otherwise = w diff --git a/src/Distribution/PackageDescription/PrettyPrint.hs b/src/Distribution/PackageDescription/PrettyPrint.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/PrettyPrint.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.PackageDescription.PrettyPrint --- Copyright : Jürgen Nicklisch-Franken 2010 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Pretty printing for cabal files --- ------------------------------------------------------------------------------ - -module Distribution.PackageDescription.PrettyPrint ( - -- * Generic package descriptions - writeGenericPackageDescription, - showGenericPackageDescription, - ppGenericPackageDescription, - - -- * Package descriptions - writePackageDescription, - showPackageDescription, - - -- ** Supplementary build information - writeHookedBuildInfo, - showHookedBuildInfo, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Fields.Pretty -import Distribution.Compat.Lens -import Distribution.PackageDescription -import Distribution.Pretty -import Distribution.Simple.Utils (writeFileAtomic, writeUTF8File) -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) -import Distribution.PackageDescription.Configuration (transformAllBuildInfos) -import Distribution.PackageDescription.FieldGrammar - (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar, - packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) - -import qualified Distribution.PackageDescription.FieldGrammar as FG -import qualified Distribution.Types.BuildInfo.Lens as L -import qualified Distribution.Types.SetupBuildInfo.Lens as L - -import Text.PrettyPrint (Doc, char, hsep, parens, text) - -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import qualified Distribution.Compat.NonEmptySet as NES - --- | Writes a .cabal file from a generic package description -writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () -writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) - --- | Writes a generic package description to a string -showGenericPackageDescription :: GenericPackageDescription -> String -showGenericPackageDescription gpd = showFields (const []) $ ppGenericPackageDescription v gpd - where - v = specVersion $ packageDescription gpd - --- | Convert a generic package description to 'PrettyField's. -ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] -ppGenericPackageDescription v gpd0 = concat - [ ppPackageDescription v (packageDescription gpd) - , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) - , ppGenPackageFlags v (genPackageFlags gpd) - , ppCondLibrary v (condLibrary gpd) - , ppCondSubLibraries v (condSubLibraries gpd) - , ppCondForeignLibs v (condForeignLibs gpd) - , ppCondExecutables v (condExecutables gpd) - , ppCondTestSuites v (condTestSuites gpd) - , ppCondBenchmarks v (condBenchmarks gpd) - ] - where - gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 - - -ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] -ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd - ++ ppSourceRepos v (sourceRepos pd) - -ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] -ppSourceRepos = map . ppSourceRepo - -ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () -ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo - where - kind = repoKind repo - -ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] -ppSetupBInfo _ Nothing = mempty -ppSetupBInfo v (Just sbi) - | defaultSetupDepends sbi = mempty - | otherwise = pure $ PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi - -ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] -ppGenPackageFlags = map . ppFlag - -ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () -ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar name) flag - -ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] -ppCondTree2 v grammar = go - where - -- TODO: recognise elif opportunities - go (CondNode it _ ifs) = - prettyFieldGrammar v grammar it ++ - concatMap ppIf ifs - - ppIf (CondBranch c thenTree Nothing) --- | isEmpty thenDoc = mempty - | otherwise = [ppIfCondition c thenDoc] - where - thenDoc = go thenTree - - ppIf (CondBranch c thenTree (Just elseTree)) = - -- See #6193 - [ ppIfCondition c (go thenTree) - , PrettySection () "else" [] (go elseTree) - ] - -ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] -ppCondLibrary _ Nothing = mempty -ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $ - ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree - -ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()] -ppCondSubLibraries v libs = - [ PrettySection () "library" [pretty n] - $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree - | (n, condTree) <- libs - ] - -ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] -ppCondForeignLibs v flibs = - [ PrettySection () "foreign-library" [pretty n] - $ ppCondTree2 v (foreignLibFieldGrammar n) condTree - | (n, condTree) <- flibs - ] - -ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()] -ppCondExecutables v exes = - [ PrettySection () "executable" [pretty n] - $ ppCondTree2 v (executableFieldGrammar n) condTree - | (n, condTree) <- exes - ] - -ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()] -ppCondTestSuites v suites = - [ PrettySection () "test-suite" [pretty n] - $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) - | (n, condTree) <- suites - ] - -ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()] -ppCondBenchmarks v suites = - [ PrettySection () "benchmark" [pretty n] - $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) - | (n, condTree) <- suites - ] - -ppCondition :: Condition ConfVar -> Doc -ppCondition (Var x) = ppConfVar x -ppCondition (Lit b) = text (show b) -ppCondition (CNot c) = char '!' <<>> (ppCondition c) -ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" - <+> ppCondition c2]) -ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" - <+> ppCondition c2]) -ppConfVar :: ConfVar -> Doc -ppConfVar (OS os) = text "os" <<>> parens (pretty os) -ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) -ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name) -ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) - -ppFlagName :: FlagName -> Doc -ppFlagName = text . unFlagName - -ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () -ppIfCondition c = PrettySection () "if" [ppCondition c] - --- | @since 2.0.0.2 -writePackageDescription :: FilePath -> PackageDescription -> IO () -writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) - ---TODO: make this use section syntax --- add equivalent for GenericPackageDescription - --- | @since 2.0.0.2 -showPackageDescription :: PackageDescription -> String -showPackageDescription = showGenericPackageDescription . pdToGpd - -pdToGpd :: PackageDescription -> GenericPackageDescription -pdToGpd pd = GenericPackageDescription - { packageDescription = pd - , gpdScannedVersion = Nothing - , genPackageFlags = [] - , condLibrary = mkCondTree <$> library pd - , condSubLibraries = mkCondTreeL <$> subLibraries pd - , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd - , condExecutables = mkCondTree' exeName <$> executables pd - , condTestSuites = mkCondTree' testName <$> testSuites pd - , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd - } - where - -- We set CondTree's [Dependency] to an empty list, as it - -- is not pretty printed anyway. - mkCondTree x = CondNode x [] [] - mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] []) - - mkCondTree' - :: (a -> UnqualComponentName) - -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a) - mkCondTree' f x = (f x, CondNode x [] []) - -------------------------------------------------------------------------------- --- Internal libs -------------------------------------------------------------------------------- - --- See Note [Dependencies on sublibraries] in Distribution.PackageDescription.Parsec --- -preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription -preProcessInternalDeps specVer gpd - | specVer >= CabalSpecV3_4 = gpd - | otherwise = transformAllBuildInfos transformBI transformSBI gpd - where - transformBI :: BuildInfo -> BuildInfo - transformBI - = over L.targetBuildDepends (concatMap transformD) - . over L.mixins (map transformM) - - transformSBI :: SetupBuildInfo -> SetupBuildInfo - transformSBI = over L.setupDepends (concatMap transformD) - - transformD :: Dependency -> [Dependency] - transformD (Dependency pn vr ln) - | pn == thisPn - = if LMainLibName `NES.member` ln - then Dependency thisPn vr mainLibSet : sublibs - else sublibs - where - sublibs = - [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet - | LSubLibName uqn <- NES.toList ln - ] - - transformD d = [d] - - transformM :: Mixin -> Mixin - transformM (Mixin pn (LSubLibName uqn) inc) - | pn == thisPn - = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc - transformM m = m - - thisPn :: PackageName - thisPn = pkgName (package (packageDescription gpd)) - -------------------------------------------------------------------------------- --- HookedBuildInfo -------------------------------------------------------------------------------- - --- | @since 2.0.0.2 -writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () -writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack - . showHookedBuildInfo - --- | @since 2.0.0.2 -showHookedBuildInfo :: HookedBuildInfo -> String -showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const []) $ - maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ - [ PrettySection () "executable:" [pretty name] - $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi - | (name, bi) <- ex_bis - ] diff --git a/src/Distribution/PackageDescription/Quirks.hs b/src/Distribution/PackageDescription/Quirks.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Quirks.hs +++ /dev/null @@ -1,340 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} --- | --- --- @since 2.2.0.0 -module Distribution.PackageDescription.Quirks (patchQuirks) where - -import Distribution.Compat.Prelude -import Distribution.Utils.MD5 -import GHC.Fingerprint (Fingerprint (..)) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Data.Map as Map - --- | Patch legacy @.cabal@ file contents to allow parsec parser to accept --- all of Hackage. --- --- Bool part of the result tells whether the output is modified. --- --- @since 2.2.0.0 -patchQuirks :: BS.ByteString -> (Bool, BS.ByteString) -patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of - Nothing -> (False, bs) - Just (post, f) - | post /= md5 output -> (False, bs) - | otherwise -> (True, output) - where - output = f bs - --- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function. -patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString) -patches = Map.fromList - -- http://hackage.haskell.org/package/unicode-transforms-0.3.3 - -- other-modules: . - -- ReadP assumed dot is empty line - [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic" - (Fingerprint 15958160436627155571 10318709190730872881) - (Fingerprint 11008465475756725834 13815629925116264363) - (bsRemove " other-modules:\n .\n") -- TODO: remove traling \n to test structural-diff - -- http://hackage.haskell.org/package/DSTM-0.1.2 - -- http://hackage.haskell.org/package/DSTM-0.1.1 - -- http://hackage.haskell.org/package/DSTM-0.1 - -- Other Modules: no dash - -- ReadP parsed as section - , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 6919263071548559054 9050746360708965827) - (Fingerprint 17015177514298962556 11943164891661867280) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed " - (Fingerprint 17313105789069667153 9610429408495338584) - (Fingerprint 17250946493484671738 17629939328766863497) - (bsReplace "Other modules:" "-- ") - , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy" - (Fingerprint 10502599650530614586 16424112934471063115) - (Fingerprint 13562014713536696107 17899511905611879358) - (bsReplace "Other modules:" "-- ") - -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3 - , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f" - (Fingerprint 18274748422558568404 4043538769550834851) - (Fingerprint 11395257416101232635 4303318131190196308) - (bsReplace " default- extensions:" "unknown-section") - -- http://hackage.haskell.org/package/vacuum-opengl-0.0 - -- \DEL character - , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 5946760521961682577 16933361639326309422) - (Fingerprint 14034745101467101555 14024175957788447824) - (bsRemove "\DEL") - , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n " - (Fingerprint 10790950110330119503 1309560249972452700) - (Fingerprint 1565743557025952928 13645502325715033593) - (bsRemove "\DEL") - -- http://hackage.haskell.org/package/ixset-1.0.4 - -- {- comments -} - , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut" - (Fingerprint 11886092342440414185 4150518943472101551) - (Fingerprint 5731367240051983879 17473925006273577821) - (bsRemoveStarting "{-") - -- : after section - -- http://hackage.haskell.org/package/ds-kanren - , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n .\n == What's in ds-kanren?\n .\n ['dis" - (Fingerprint 2804006762382336875 9677726932108735838) - (Fingerprint 9830506174094917897 12812107316777006473) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the language.\n\nlicense: MIT\nlicense-file: " - (Fingerprint 9130259649220396193 2155671144384738932) - (Fingerprint 1847988234352024240 4597789823227580457) - (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"") - , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 6150019278861565482 3066802658031228162) - (Fingerprint 9124826020564520548 15629704249829132420) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:" - (Fingerprint 4639805967994715694 7859317050376284551) - (Fingerprint 5566222290622325231 873197212916959151) - (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"") - , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel \nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: " - (Fingerprint 10546509771395401582 245508422312751943) - (Fingerprint 5169853482576003304 7247091607933993833) - (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section") - , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: " - (Fingerprint 7803544783533485151 10807347873998191750) - (Fingerprint 1665635316718752601 16212378357991151549) - (bsReplace "build depends:" "--") - , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program" - (Fingerprint 4403237110790078829 15392625961066653722) - (Fingerprint 10218887328390239431 4644205837817510221) - (bsReplace "other modules:" "--") - -- &&! - -- http://hackage.haskell.org/package/hblas-0.3.0.0 - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 8570120150072467041 18315524331351505945) - (Fingerprint 10838007242302656005 16026440017674974175) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 5262875856214215155 10846626274067555320) - (Fingerprint 3022954285783401045 13395975869915955260) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- " - (Fingerprint 54222628930951453 5526514916844166577) - (Fingerprint 1749630806887010665 8607076506606977549) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 6817250511240350300 15278852712000783849) - (Fingerprint 15757717081429529536 15542551865099640223) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 8310050400349211976 201317952074418615) - (Fingerprint 10283381191257209624 4231947623042413334) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 7010988292906098371 11591884496857936132) - (Fingerprint 6158672440010710301 6419743768695725095) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 2076850805659055833 16615160726215879467) - (Fingerprint 10634706281258477722 5285812379517916984) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)" - (Fingerprint 11850020631622781099 11956481969231030830) - (Fingerprint 13702868780337762025 13383526367149067158) - (bsReplace "&&!" "&& !") - , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo" - (Fingerprint 13690322768477779172 19704059263540994) - (Fingerprint 11189374824645442376 8363528115442591078) - (bsReplace "&&!" "&& !") - -- flag used, but not defined - , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi" - (Fingerprint 6910727116443152200 15401634478524888973) - (Fingerprint 16551412117098094368 16260377389127603629) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 14320987921316832277 10031098243571536929) - (Fingerprint 7959395602414037224 13279941216182213050) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 3809078390223299128 10796026010775813741) - (Fingerprint 1127231189459220796 12088367524333209349) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: " - (Fingerprint 13860013038089410950 12479824176801390651) - (Fingerprint 4687484721703340391 8013395164515771785) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 16215911397419608203 15594928482155652475) - (Fingerprint 15120681510314491047 2666192399775157359) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 16593139224723441188 4052919014346212001) - (Fingerprint 3577381082410411593 11481899387780544641) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 9321301260802539374 1316392715016096607) - (Fingerprint 3784628652257760949 12662640594755291035) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 2546901804824433337 2059732715322561176) - (Fingerprint 8082068680348326500 615008613291421947) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho" - (Fingerprint 2282380737467965407 12457554753171662424) - (Fingerprint 17324757216926991616 17172911843227482125) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te" - (Fingerprint 12907988890480595481 11078473638628359710) - (Fingerprint 13246185333368731848 4663060731847518614) - (bsReplace "flag(llvm-fast)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: " - (Fingerprint 12386777729082870356 17414156731912743711) - (Fingerprint 3452290353395041602 14102887112483033720) - (bsReplace "flag(sse42)" "False") - , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen" - (Fingerprint 6870520675313101180 14553457351296240636) - (Fingerprint 12481021059537696455 14711088786769892762) - (bsReplace "flag(sse42)" "False") - -- leading zeros in version digits - -- https://github.com/haskell-infra/hackage-trustees/issues/128 - -- https://github.com/haskell/cabal/issues/5092 - -- https://github.com/haskell/cabal/issues/5138 - , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent" - (Fingerprint 8458530898096910998 3228538743646501413) - (Fingerprint 14470502514907936793 17514354054641875371) - (bsReplace "0.2017.02.26" "0.2017.2.26") - , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 1450130849535097473 11742099607098860444) - (Fingerprint 16679762943850814021 4253724355613883542) - (bsReplace "0.2017.05.01" "0.2017.5.1") - , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel \nmaintainer: Andreas Abel \n" - (Fingerprint 297248532398492441 17322625167861324800) - (Fingerprint 634812045126693280 1755581866539318862) - (bsReplace "0.2017.05.02" "0.2017.5.2") - , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: " - (Fingerprint 3697869560530373941 3942982281026987312) - (Fingerprint 14344526114710295386 16386400353475114712) - (bsReplace "0.2017.5.02" "0.2017.5.2") - , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel =1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 9155400339287317061 14812953666990892802) - (Fingerprint 7687053346032173923 15384472501136606592) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") - , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner \nstability: experimental\nhomepage: h" - (Fingerprint 2984391146441073709 11728234882049907993) - (Fingerprint 12058479081855347701 14017937756688869826) - (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "") - ] - where - mk a b c d = ((a, b), (c, d)) - --- | Helper to create entries in patches -_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO () -_makePatchKey fp transform = do - contents <- BS.readFile fp - let output = transform contents - let Fingerprint hi lo = md5 contents - let Fingerprint hi' lo' = md5 output - putStrLn - $ showString " , mk " - . shows (BS.take 256 contents) - . showString "\n (Fingerprint " - . shows hi - . showString " " - . shows lo - . showString ")\n (Fingerprint " - . shows hi' - . showString " " - . shows lo' - . showString ")" - $ "" - -------------------------------------------------------------------------------- --- Patch helpers -------------------------------------------------------------------------------- - -bsRemove - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemove needle haystack = case BS.breakSubstring needle haystack of - (h, t) -> BS.append h (BS.drop (BS.length needle) t) - -bsReplace - :: BS.ByteString -- ^ needle - -> BS.ByteString -- ^ replacement - -> BS.ByteString -> BS.ByteString -bsReplace needle repl haystack = case BS.breakSubstring needle haystack of - (h, t) - | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t)) - | otherwise -> haystack - -bsRemoveStarting - :: BS.ByteString -- ^ needle - -> BS.ByteString -> BS.ByteString -bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of - (h, _) -> h diff --git a/src/Distribution/PackageDescription/Utils.hs b/src/Distribution/PackageDescription/Utils.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/Utils.hs +++ /dev/null @@ -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" diff --git a/src/Distribution/Parsec.hs b/src/Distribution/Parsec.hs deleted file mode 100644 --- a/src/Distribution/Parsec.hs +++ /dev/null @@ -1,524 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Parsec ( - Parsec(..), - ParsecParser (..), - runParsecParser, - runParsecParser', - simpleParsec, - simpleParsecBS, - simpleParsec', - simpleParsecW', - lexemeParsec, - eitherParsec, - explicitEitherParsec, - explicitEitherParsec', - -- * CabalParsing and diagnostics - CabalParsing (..), - -- ** Warnings - PWarnType (..), - PWarning (..), - showPWarning, - -- ** Errors - PError (..), - showPError, - -- * Position - Position (..), - incPos, - retPos, - showPos, - zeroPos, - -- * Utilities - parsecToken, - parsecToken', - parsecFilePath, - parsecQuoted, - parsecMaybeQuoted, - parsecCommaList, - parsecCommaNonEmpty, - parsecLeadingCommaList, - parsecLeadingCommaNonEmpty, - parsecOptCommaList, - parsecLeadingOptCommaList, - parsecStandard, - parsecUnqualComponentName, - ) where - -import Data.ByteString (ByteString) -import Data.Char (digitToInt, intToDigit) -import Data.List (transpose) -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Distribution.Parsec.Error (PError (..), showPError) -import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) -import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) -import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) -import Numeric (showIntAtBase) -import Prelude () - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Distribution.Compat.MonadFail as Fail -import qualified Text.Parsec as Parsec - -------------------------------------------------------------------------------- --- Class -------------------------------------------------------------------------------- - --- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. --- --- For parsing @.cabal@ like file structure, see "Distribution.Fields". --- -class Parsec a where - parsec :: CabalParsing m => m a - --- | Parsing class which --- --- * can report Cabal parser warnings. --- --- * knows @cabal-version@ we work with --- -class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where - parsecWarning :: PWarnType -> String -> m () - - parsecHaskellString :: m String - parsecHaskellString = stringLiteral - - askCabalSpecVersion :: m CabalSpecVersion - --- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. -lexemeParsec :: (CabalParsing m, Parsec a) => m a -lexemeParsec = parsec <* P.spaces - -newtype ParsecParser a = PP { unPP - :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a - } - -liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a -liftParsec p = PP $ \_ -> p - -instance Functor ParsecParser where - fmap f p = PP $ \v -> fmap f (unPP p v) - {-# INLINE fmap #-} - - x <$ p = PP $ \v -> x <$ unPP p v - {-# INLINE (<$) #-} - -instance Applicative ParsecParser where - pure = liftParsec . pure - {-# INLINE pure #-} - - f <*> x = PP $ \v -> unPP f v <*> unPP x v - {-# INLINE (<*>) #-} - f *> x = PP $ \v -> unPP f v *> unPP x v - {-# INLINE (*>) #-} - f <* x = PP $ \v -> unPP f v <* unPP x v - {-# INLINE (<*) #-} - -instance Alternative ParsecParser where - empty = liftParsec empty - - a <|> b = PP $ \v -> unPP a v <|> unPP b v - {-# INLINE (<|>) #-} - - many p = PP $ \v -> many (unPP p v) - {-# INLINE many #-} - - some p = PP $ \v -> some (unPP p v) - {-# INLINE some #-} - -instance Monad ParsecParser where - return = pure - - m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v - {-# INLINE (>>=) #-} - (>>) = (*>) - {-# INLINE (>>) #-} - -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif - -instance MonadPlus ParsecParser where - mzero = empty - mplus = (<|>) - -instance Fail.MonadFail ParsecParser where - fail = P.unexpected - -instance P.Parsing ParsecParser where - try p = PP $ \v -> P.try (unPP p v) - p d = PP $ \v -> unPP p v P. d - skipMany p = PP $ \v -> P.skipMany (unPP p v) - skipSome p = PP $ \v -> P.skipSome (unPP p v) - unexpected = liftParsec . P.unexpected - eof = liftParsec P.eof - notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) - -instance P.CharParsing ParsecParser where - satisfy = liftParsec . P.satisfy - char = liftParsec . P.char - notChar = liftParsec . P.notChar - anyChar = liftParsec P.anyChar - string = liftParsec . P.string - -instance CabalParsing ParsecParser where - parsecWarning t w = liftParsec $ do - spos <- Parsec.getPosition - Parsec.modifyState - (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) - askCabalSpecVersion = PP pure - --- | Parse a 'String' with 'lexemeParsec'. -simpleParsec :: Parsec a => String -> Maybe a -simpleParsec - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromString - --- | Like 'simpleParsec' but for 'ByteString' -simpleParsecBS :: Parsec a => ByteString -> Maybe a -simpleParsecBS - = either (const Nothing) Just - . runParsecParser lexemeParsec "" - . fieldLineStreamFromBS - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- --- @since 3.4.0.0 -simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsec' spec - = either (const Nothing) Just - . runParsecParser' spec lexemeParsec "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. --- Fail if there are any warnings. --- --- @since 3.4.0.0 -simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a -simpleParsecW' spec - = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) - . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" - . fieldLineStreamFromString - --- | Parse a 'String' with 'lexemeParsec'. -eitherParsec :: Parsec a => String -> Either String a -eitherParsec = explicitEitherParsec parsec - --- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. -explicitEitherParsec :: ParsecParser a -> String -> Either String a -explicitEitherParsec parser - = either (Left . show) Right - . runParsecParser (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted. --- See 'explicitEitherParsec'. --- --- @since 3.4.0.0 --- -explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a -explicitEitherParsec' spec parser - = either (Left . show) Right - . runParsecParser' spec (parser <* P.spaces) "" - . fieldLineStreamFromString - --- | Run 'ParsecParser' with 'cabalSpecLatest'. -runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser = runParsecParser' cabalSpecLatest - --- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. --- --- @since 3.0.0.0 --- -runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a -runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n - -instance Parsec a => Parsec (Identity a) where - parsec = Identity <$> parsec - -instance Parsec Bool where - parsec = P.munch1 isAlpha >>= postprocess - where - postprocess str - | str == "True" = pure True - | str == "False" = pure False - | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True - | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False - | otherwise = fail $ "Not a boolean: " ++ str - where - lstr = map toLower str - caseWarning = - "Boolean values are case sensitive, use 'True' or 'False'." - --- | @[^ ,]@ -parsecToken :: CabalParsing m => m String -parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) - --- | @[^ ]@ -parsecToken' :: CabalParsing m => m String -parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) - -checkNotDoubleDash :: CabalParsing m => String -> m String -checkNotDoubleDash s = do - when (s == "--") $ parsecWarning PWTDoubleDash $ unwords - [ "Double-dash token found." - , "Note: there are no end-of-line comments in .cabal files, only whole line comments." - , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" - ] - - return s - -parsecFilePath :: CabalParsing m => m FilePath -parsecFilePath = parsecToken - --- | Parse a benchmark/test-suite types. -parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a -parsecStandard f = do - cs <- some $ P.try (component <* P.char '-') - ver <- parsec - let name = map toLower (intercalate "-" cs) - return $! f ver name - where - component = do - cs <- P.munch1 isAlphaNum - if all isDigit cs then fail "all digit component" else return cs - -- each component must contain an alphabetic character, to avoid - -- ambiguity in identifiers like foo-1 (the 1 is the version number). - -parsecCommaList :: CabalParsing m => m a -> m [a] -parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - -parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") - --- | Like 'parsecCommaList' but accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- @ -parsecLeadingCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingCommaList p = do - c <- P.optional comma - case c of - Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - --- | --- --- @since 3.4.0.0 -parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) -parsecLeadingCommaNonEmpty p = do - c <- P.optional comma - case c of - Nothing -> P.sepEndByNonEmpty lp comma - Just _ -> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - -parsecOptCommaList :: CabalParsing m => m a -> m [a] -parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) - where - comma = P.char ',' *> P.spaces - --- | Like 'parsecOptCommaList' but --- --- * require all or none commas --- * accept leading or trailing comma. --- --- @ --- p (comma p)* -- p `sepBy` comma --- (comma p)* -- leading comma --- (p comma)* -- trailing comma --- p* -- no commas: many p --- @ --- --- @since 3.0.0.0 --- -parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] -parsecLeadingOptCommaList p = do - c <- P.optional comma - case c of - Nothing -> sepEndBy1Start <|> pure [] - Just _ -> toList <$> P.sepByNonEmpty lp comma - where - lp = p <* P.spaces - comma = P.char ',' *> P.spaces P. "comma" - - sepEndBy1Start = do - x <- lp - c <- P.optional comma - case c of - Nothing -> (x :) <$> many lp - Just _ -> (x :) <$> P.sepEndBy lp comma - --- | Content isn't unquoted -parsecQuoted :: CabalParsing m => m a -> m a -parsecQuoted = P.between (P.char '"') (P.char '"') - --- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@. -parsecMaybeQuoted :: CabalParsing m => m a -> m a -parsecMaybeQuoted p = parsecQuoted p <|> p - -parsecUnqualComponentName :: forall m. CabalParsing m => m String -parsecUnqualComponentName = state0 DList.empty where - -- - -- using @kleene@ package we can easily see that - -- we need only two states to recognize - -- unqual-component-name - -- - -- Compare with declarative - -- 'Distribution.FieldGrammar.Described.reUnqualComponent'. - -- - -- @ - -- import Kleene - -- import Kleene.Internal.Pretty - -- import Algebra.Lattice - -- import Data.Char - -- - -- import qualified Data.RangeSet.Map as RSet - -- - -- main = do - -- -- this is an approximation, to get an idea. - -- let component :: RE Char - -- component = star alphaNum <> alpha <> star alphaNum - -- - -- alphaNum = alpha \/ num - -- alpha = unions $ map char ['a'..'z'] - -- num = unions $ map char ['0'..'9'] - -- - -- re :: RE Char - -- re = component <> star (char '-' <> component) - -- - -- putPretty re - -- putPretty $ fromTM re - -- @ - - state0 :: DList.DList Char -> m String - state0 acc = do - c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) - case () of - _ | isDigit c -> state0 (DList.snoc acc c) - | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - state1 :: DList.DList Char -> m String - state1 acc = state1' acc `alt` return (DList.toList acc) - - state1' :: DList.DList Char -> m String - state1' acc = do - c <- ch - case () of - _ | isAlphaNum c -> state1 (DList.snoc acc c) - | c == '-' -> state0 (DList.snoc acc c) - | otherwise -> fail ("Internal error, after " ++ DList.toList acc) - - ch :: m Char - !ch = P.satisfy (\c -> isAlphaNum c || c == '-') - - alt :: m String -> m String -> m String - !alt = (<|>) - -stringLiteral :: forall m. P.CharParsing m => m String -stringLiteral = lit where - lit :: m String - lit = foldr (maybe id (:)) "" - <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) - P. "string" - - stringChar :: m (Maybe Char) - stringChar = Just <$> stringLetter - <|> stringEscape - P. "string character" - - stringLetter :: m Char - stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - - stringEscape :: m (Maybe Char) - stringEscape = P.char '\\' *> esc where - esc :: m (Maybe Char) - esc = Nothing <$ escapeGap - <|> Nothing <$ escapeEmpty - <|> Just <$> escapeCode - - escapeEmpty, escapeGap :: m Char - escapeEmpty = P.char '&' - escapeGap = P.skipSpaces1 *> (P.char '\\' P. "end of string gap") - -escapeCode :: forall m. P.CharParsing m => m Char -escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" - where - charControl, charNum :: m Char - charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) - charNum = toEnum <$> num - where - num :: m Int - num = bounded 10 maxchar - <|> (P.char 'o' *> bounded 8 maxchar) - <|> (P.char 'x' *> bounded 16 maxchar) - maxchar = fromEnum (maxBound :: Char) - - bounded :: Int -> Int -> m Int - bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 - <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") - where - thedigits :: [m Char] - thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) - - toomuch :: m a - toomuch = P.unexpected "out-of-range numeric escape sequence" - - bounded', bounded'' :: [m Char] -> [Int] -> m [Char] - bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) - <|> bounded'' dps bds - bounded' [] _ = error "bounded called with base 0" - bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch - bounded'' dps (bd : bds) = let anyd :: m Char - anyd = P.choice dps - - nomore :: m () - nomore = P.notFollowedBy anyd <|> toomuch - - (low, ex, high) = case splitAt bd dps of - (low', ex' : high') -> (low', ex', high') - (_, _) -> error "escapeCode: Logic error" - in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore - <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) - <|> if not (null bds) - then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore - else empty - atMost n p | n <= 0 = pure [] - | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] - - charEsc :: m Char - charEsc = P.choice $ parseEsc <$> escMap - - parseEsc (c,code) = code <$ P.char c - escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" - - charAscii :: m Char - charAscii = P.choice $ parseAscii <$> asciiMap - - parseAscii (asc,code) = P.try $ code <$ P.string asc - asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - ascii2codes, ascii3codes :: [String] - ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" - , "SI","EM","FS","GS","RS","US","SP"] - ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" - ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" - ,"SYN","ETB","CAN","SUB","ESC","DEL"] - ascii2, ascii3 :: String - ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" - ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL" diff --git a/src/Distribution/Parsec/Error.hs b/src/Distribution/Parsec/Error.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Error.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Error ( - PError (..), - showPError, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Parser error. -data PError = PError Position String - deriving (Show, Generic) - -instance Binary PError -instance NFData PError where rnf = genericRnf - -showPError :: FilePath -> PError -> String -showPError fpath (PError pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/src/Distribution/Parsec/FieldLineStream.hs b/src/Distribution/Parsec/FieldLineStream.hs deleted file mode 100644 --- a/src/Distribution/Parsec/FieldLineStream.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror #-} -module Distribution.Parsec.FieldLineStream ( - FieldLineStream (..), - fieldLineStreamFromString, - fieldLineStreamFromBS, - fieldLineStreamEnd, - ) where - -import Data.Bits -import Data.ByteString (ByteString) -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (toUTF8BS) -import Prelude () - -import qualified Data.ByteString as BS -import qualified Text.Parsec as Parsec - --- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. -data FieldLineStream - = FLSLast !ByteString - | FLSCons {-# UNPACK #-} !ByteString FieldLineStream - deriving Show - -fieldLineStreamEnd :: FieldLineStream -fieldLineStreamEnd = FLSLast mempty - --- | Convert 'String' to 'FieldLineStream'. --- --- /Note:/ inefficient! -fieldLineStreamFromString :: String -> FieldLineStream -fieldLineStreamFromString = FLSLast . toUTF8BS - -fieldLineStreamFromBS :: ByteString -> FieldLineStream -fieldLineStreamFromBS = FLSLast - -instance Monad m => Parsec.Stream FieldLineStream m Char where - uncons (FLSLast bs) = return $ case BS.uncons bs of - Nothing -> Nothing - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) - - uncons (FLSCons bs s) = return $ case BS.uncons bs of - -- as lines are glued with '\n', we return '\n' here! - Nothing -> Just ('\n', s) - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) - --- Based on implementation 'decodeStringUtf8' -unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) -unconsChar c0 bs0 f next - | c0 <= 0x7F = (chr (fromIntegral c0), f bs0) - | c0 <= 0xBF = (replacementChar, f bs0) - | c0 <= 0xDF = twoBytes - | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF) - | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7) - | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3) - | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1) - | otherwise = error $ "not implemented " ++ show c0 - where - twoBytes = case BS.uncons bs0 of - Nothing -> (replacementChar, next) - Just (c1, bs1) - | c1 .&. 0xC0 == 0x80 -> - if d >= 0x80 - then (chr d, f bs1) - else (replacementChar, f bs1) - | otherwise -> (replacementChar, f bs1) - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a) - moreBytes 1 overlong bs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = (chr acc, f bs') - | otherwise - = (replacementChar, f bs') - - moreBytes byteCount overlong bs' acc = case BS.uncons bs' of - Nothing -> (replacementChar, f bs') - Just (cn, bs1) - | cn .&. 0xC0 == 0x80 -> moreBytes - (byteCount-1) - overlong - bs1 - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - | otherwise -> (replacementChar, f bs1) - -replacementChar :: Char -replacementChar = '\xfffd' diff --git a/src/Distribution/Parsec/Position.hs b/src/Distribution/Parsec/Position.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Position.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Position ( - Position (..), - incPos, - retPos, - showPos, - zeroPos, - positionCol, - positionRow, - ) where - -import Distribution.Compat.Prelude -import Prelude () - --- | 1-indexed row and column positions in a file. -data Position = Position - {-# UNPACK #-} !Int -- row - {-# UNPACK #-} !Int -- column - deriving (Eq, Ord, Show, Generic) - -instance Binary Position -instance NFData Position where rnf = genericRnf - --- | Shift position by n columns to the right. -incPos :: Int -> Position -> Position -incPos n (Position row col) = Position row (col + n) - --- | Shift position to beginning of next row. -retPos :: Position -> Position -retPos (Position row _col) = Position (row + 1) 1 - -showPos :: Position -> String -showPos (Position row col) = show row ++ ":" ++ show col - -zeroPos :: Position -zeroPos = Position 0 0 - --- | @since 3.0.0.0 -positionCol :: Position -> Int -positionCol (Position _ c) = c - --- | @since 3.0.0.0 -positionRow :: Position -> Int -positionRow (Position r _) = r diff --git a/src/Distribution/Parsec/Warning.hs b/src/Distribution/Parsec/Warning.hs deleted file mode 100644 --- a/src/Distribution/Parsec/Warning.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Parsec.Warning ( - PWarning (..), - PWarnType (..), - showPWarning, - ) where - -import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Prelude () -import System.FilePath (normalise) - --- | Type of parser warning. We do classify warnings. --- --- Different application may decide not to show some, or have fatal behaviour on others -data PWarnType - = PWTOther -- ^ Unclassified warning - | PWTUTF -- ^ Invalid UTF encoding - | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@ - | PWTVersionTag -- ^ there are version with tags - | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified - | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified - | PWTDeprecatedField - | PWTInvalidSubsection - | PWTUnknownField - | PWTUnknownSection - | PWTTrailingFields - | PWTExtraMainIs -- ^ extra main-is field - | PWTExtraTestModule -- ^ extra test-module field - | PWTExtraBenchmarkModule -- ^ extra benchmark-module field - | PWTLexNBSP - | PWTLexBOM - | PWTLexTab - | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch - | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment - | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once. - | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See . - - | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8) - | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6) - - | PWTSpecVersion -- ^ Warnings about cabal-version format. - - | PWTEmptyFilePath -- ^ Empty filepath, i.e. literally "" - - | PWTExperimental -- ^ Experimental feature - deriving (Eq, Ord, Show, Enum, Bounded, Generic) - -instance Binary PWarnType -instance NFData PWarnType where rnf = genericRnf - --- | Parser warning. -data PWarning = PWarning !PWarnType !Position String - deriving (Show, Generic) - -instance Binary PWarning -instance NFData PWarning where rnf = genericRnf - -showPWarning :: FilePath -> PWarning -> String -showPWarning fpath (PWarning _ pos msg) = - normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg diff --git a/src/Distribution/Pretty.hs b/src/Distribution/Pretty.hs deleted file mode 100644 --- a/src/Distribution/Pretty.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Distribution.Pretty ( - Pretty (..), - prettyShow, - defaultStyle, - flatStyle, - -- * Utilities - showFilePath, - showToken, - showTokenStr, - showFreeText, - showFreeTextV3, - -- * Deprecated - Separator, - ) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude -import Prelude () - -import qualified Text.PrettyPrint as PP - -class Pretty a where - pretty :: a -> PP.Doc - - prettyVersioned :: CabalSpecVersion -> a -> PP.Doc - prettyVersioned _ = pretty - --- | @since 3.4.0.0 -instance Pretty PP.Doc where - pretty = id - -instance Pretty Bool where - pretty = PP.text . show - -instance Pretty Int where - pretty = PP.text . show - -instance Pretty a => Pretty (Identity a) where - pretty = pretty . runIdentity - -prettyShow :: Pretty a => a -> String -prettyShow = PP.renderStyle defaultStyle . pretty - --- | The default rendering style used in Cabal for console --- output. It has a fixed page width and adds line breaks --- automatically. -defaultStyle :: PP.Style -defaultStyle = PP.Style { PP.mode = PP.PageMode - , PP.lineLength = 79 - , PP.ribbonsPerLine = 1.0 - } - --- | A style for rendering all on one line. -flatStyle :: PP.Style -flatStyle = PP.Style { PP.mode = PP.LeftMode - , PP.lineLength = err "lineLength" - , PP.ribbonsPerLine = err "ribbonsPerLine" - } - where - err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++ - "This should never happen and indicates a bug in Cabal.") - -------------------------------------------------------------------------------- --- Utilities -------------------------------------------------------------------------------- - --- TODO: remove when ReadP parser is gone. -type Separator = [PP.Doc] -> PP.Doc - -showFilePath :: FilePath -> PP.Doc -showFilePath = showToken - -showToken :: String -> PP.Doc -showToken = PP.text . showTokenStr - -showTokenStr :: String -> String -showTokenStr str - -- if token looks like a comment (starts with --), print it in quotes - | "--" `isPrefixOf` str = show str - -- also if token ends with a colon (e.g. executable name), print it in quotes - | ":" `isSuffixOf` str = show str - | not (any dodgy str) && not (null str) = str - | otherwise = show str - where - dodgy c = isSpace c || c == ',' - - --- | Pretty-print free-format text, ensuring that it is vertically aligned, --- and with blank lines replaced by dots for correct re-parsing. -showFreeText :: String -> PP.Doc -showFreeText "" = mempty -showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ] - --- | Pretty-print free-format text. --- Since @cabal-version: 3.0@ we don't replace blank lines with dots. --- --- @since 3.0.0.0 -showFreeTextV3 :: String -> PP.Doc -showFreeTextV3 "" = mempty -showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ] - --- | 'lines_' breaks a string up into a list of strings at newline --- characters. The resulting strings do not contain newlines. -lines_ :: String -> [String] -lines_ [] = [""] -lines_ s = - let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines_ s'' diff --git a/src/Distribution/ReadE.hs b/src/Distribution/ReadE.hs --- a/src/Distribution/ReadE.hs +++ b/src/Distribution/ReadE.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE LambdaCase #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.ReadE -- Copyright : Jose Iborra 2008 @@ -8,29 +11,37 @@ -- Portability : portable -- -- Simple parsing with failure +module Distribution.ReadE + ( -- * ReadE + ReadE (..) + , succeedReadE + , failReadE -module Distribution.ReadE ( - -- * ReadE - ReadE(..), succeedReadE, failReadE, - -- * Projections - readEOrFail, - parsecToReadE, + -- * Projections + , parsecToReadE + , parsecToReadEErr + + -- * Parse Errors + , unexpectMsgString ) where +import qualified Data.Bifunctor as Bi (first) import Distribution.Compat.Prelude import Prelude () import Distribution.Parsec import Distribution.Parsec.FieldLineStream +import qualified Text.Parsec.Error as Parsec -- | Parser with simple error reporting newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} -type ErrorMsg = String +type ErrorMsg = String + instance Functor ReadE where fmap f (ReadE p) = ReadE $ \txt -> case p txt of - Right a -> Right (f a) - Left err -> Left err + Right a -> Right (f a) + Left err -> Left err succeedReadE :: (String -> a) -> ReadE a succeedReadE f = ReadE (Right . f) @@ -38,12 +49,23 @@ failReadE :: ErrorMsg -> ReadE a failReadE = ReadE . const . Left -readEOrFail :: ReadE a -> String -> a -readEOrFail r = either error id . runReadE r +runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a +runParsecFromString p txt = + runParsecParser p "" (fieldLineStreamFromString txt) parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a parsecToReadE err p = ReadE $ \txt -> - case runParsecParser p "" (fieldLineStreamFromString txt) of - Right x -> Right x - Left _e -> Left (err txt) --- TODO: use parsec error to make 'ErrorMsg'. + const (err txt) `Bi.first` runParsecFromString p txt + +parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a +parsecToReadEErr err p = + ReadE $ + Bi.first err . runParsecFromString p + +-- Show only unexpected error messages +unexpectMsgString :: Parsec.ParseError -> String +unexpectMsgString = + unlines + . map Parsec.messageString + . filter (\case Parsec.UnExpect _ -> True; _ -> False) + . Parsec.errorMessages diff --git a/src/Distribution/SPDX.hs b/src/Distribution/SPDX.hs deleted file mode 100644 --- a/src/Distribution/SPDX.hs +++ /dev/null @@ -1,40 +0,0 @@ --- | This module implements SPDX specification version 2.1 with a version 3.0 license list. --- --- Specification is available on -module Distribution.SPDX ( - -- * License - License (..), - -- * License expression - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - -- * License identifier - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - mkLicenseId, - licenseIdList, - -- * License exception - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - -- * License reference - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - -- * License list version - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.License -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseExpression -import Distribution.SPDX.LicenseReference -import Distribution.SPDX.LicenseListVersion diff --git a/src/Distribution/SPDX/License.hs b/src/Distribution/SPDX/License.hs deleted file mode 100644 --- a/src/Distribution/SPDX/License.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.License ( - License (..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec -import Distribution.SPDX.LicenseExpression - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Declared license. --- See [section 3.15 of SPDX Specification 2.1](https://spdx.org/spdx-specification-21-web-version#h.1hmsyys) --- --- /Note:/ the NOASSERTION case is omitted. --- --- Old 'License' can be migrated using following rules: --- --- * @AllRightsReserved@ and @UnspecifiedLicense@ to 'NONE'. --- No license specified which legally defaults to /All Rights Reserved/. --- The package may not be legally modified or redistributed by anyone but --- the rightsholder. --- --- * @OtherLicense@ can be converted to 'LicenseRef' pointing to the file --- in the package. --- --- * @UnknownLicense@ i.e. other licenses of the form @name-x.y@, should be --- covered by SPDX license list, otherwise use 'LicenseRef'. --- --- * @PublicDomain@ isn't covered. Consider using CC0. --- See --- for more information. --- -data License - = NONE - -- ^ if the package contains no license information whatsoever; or - | License LicenseExpression - -- ^ A valid SPDX License Expression as defined in Appendix IV. - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary License -instance Structured License - -instance NFData License where - rnf NONE = () - rnf (License l) = rnf l - -instance Pretty License where - pretty NONE = Disp.text "NONE" - pretty (License l) = pretty l - --- | --- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License --- Right (License (EAnd (ELicense (ELicenseId BSD_3_Clause) Nothing) (ELicense (ELicenseId MIT) Nothing))) --- --- >>> eitherParsec "NONE" :: Either String License --- Right NONE --- -instance Parsec License where - parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec diff --git a/src/Distribution/SPDX/LicenseExceptionId.hs b/src/Distribution/SPDX/LicenseExceptionId.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseExceptionId.hs +++ /dev/null @@ -1,316 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExceptionId ( - LicenseExceptionId (..), - licenseExceptionId, - licenseExceptionName, - mkLicenseExceptionId, - licenseExceptionIdList, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseExceptionId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseExceptionId - = DS389_exception -- ^ @389-exception@, 389 Directory Server Exception - | Autoconf_exception_2_0 -- ^ @Autoconf-exception-2.0@, Autoconf exception 2.0 - | Autoconf_exception_3_0 -- ^ @Autoconf-exception-3.0@, Autoconf exception 3.0 - | Bison_exception_2_2 -- ^ @Bison-exception-2.2@, Bison exception 2.2 - | Bootloader_exception -- ^ @Bootloader-exception@, Bootloader Distribution Exception - | Classpath_exception_2_0 -- ^ @Classpath-exception-2.0@, Classpath exception 2.0 - | CLISP_exception_2_0 -- ^ @CLISP-exception-2.0@, CLISP exception 2.0 - | DigiRule_FOSS_exception -- ^ @DigiRule-FOSS-exception@, DigiRule FOSS License Exception - | ECos_exception_2_0 -- ^ @eCos-exception-2.0@, eCos exception 2.0 - | Fawkes_Runtime_exception -- ^ @Fawkes-Runtime-exception@, Fawkes Runtime Exception - | FLTK_exception -- ^ @FLTK-exception@, FLTK exception - | Font_exception_2_0 -- ^ @Font-exception-2.0@, Font exception 2.0 - | Freertos_exception_2_0 -- ^ @freertos-exception-2.0@, FreeRTOS Exception 2.0 - | GCC_exception_2_0 -- ^ @GCC-exception-2.0@, GCC Runtime Library exception 2.0 - | GCC_exception_3_1 -- ^ @GCC-exception-3.1@, GCC Runtime Library exception 3.1 - | Gnu_javamail_exception -- ^ @gnu-javamail-exception@, GNU JavaMail exception - | GPL_3_0_linking_exception -- ^ @GPL-3.0-linking-exception@, GPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10 - | GPL_3_0_linking_source_exception -- ^ @GPL-3.0-linking-source-exception@, GPL-3.0 Linking Exception (with Corresponding Source), SPDX License List 3.9, SPDX License List 3.10 - | GPL_CC_1_0 -- ^ @GPL-CC-1.0@, GPL Cooperation Commitment 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | I2p_gpl_java_exception -- ^ @i2p-gpl-java-exception@, i2p GPL+Java Exception - | LGPL_3_0_linking_exception -- ^ @LGPL-3.0-linking-exception@, LGPL-3.0 Linking Exception, SPDX License List 3.9, SPDX License List 3.10 - | Libtool_exception -- ^ @Libtool-exception@, Libtool Exception - | Linux_syscall_note -- ^ @Linux-syscall-note@, Linux Syscall Note - | LLVM_exception -- ^ @LLVM-exception@, LLVM Exception, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | LZMA_exception -- ^ @LZMA-exception@, LZMA exception - | Mif_exception -- ^ @mif-exception@, Macros and Inline Functions Exception - | Nokia_Qt_exception_1_1 -- ^ @Nokia-Qt-exception-1.1@, Nokia Qt LGPL exception 1.1, SPDX License List 3.0, SPDX License List 3.2 - | OCaml_LGPL_linking_exception -- ^ @OCaml-LGPL-linking-exception@, OCaml LGPL Linking Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OCCT_exception_1_0 -- ^ @OCCT-exception-1.0@, Open CASCADE Exception 1.0 - | OpenJDK_assembly_exception_1_0 -- ^ @OpenJDK-assembly-exception-1.0@, OpenJDK Assembly exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Openvpn_openssl_exception -- ^ @openvpn-openssl-exception@, OpenVPN OpenSSL Exception - | PS_or_PDF_font_exception_20170817 -- ^ @PS-or-PDF-font-exception-20170817@, PS/PDF font exception (2017-08-17), SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qt_GPL_exception_1_0 -- ^ @Qt-GPL-exception-1.0@, Qt GPL exception 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qt_LGPL_exception_1_1 -- ^ @Qt-LGPL-exception-1.1@, Qt LGPL exception 1.1, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Qwt_exception_1_0 -- ^ @Qwt-exception-1.0@, Qwt exception 1.0 - | SHL_2_0 -- ^ @SHL-2.0@, Solderpad Hardware License v2.0, SPDX License List 3.9, SPDX License List 3.10 - | SHL_2_1 -- ^ @SHL-2.1@, Solderpad Hardware License v2.1, SPDX License List 3.9, SPDX License List 3.10 - | Swift_exception -- ^ @Swift-exception@, Swift Exception, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | U_boot_exception_2_0 -- ^ @u-boot-exception-2.0@, U-Boot exception 2.0 - | Universal_FOSS_exception_1_0 -- ^ @Universal-FOSS-exception-1.0@, Universal FOSS Exception, Version 1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | WxWindows_exception_3_1 -- ^ @WxWindows-exception-3.1@, WxWindows Library Exception 3.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseExceptionId where - put = Binary.putWord8 . fromIntegral . fromEnum - get = do - i <- Binary.getWord8 - if i > fromIntegral (fromEnum (maxBound :: LicenseExceptionId)) - then fail "Too large LicenseExceptionId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseExceptionId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseExceptionId where - pretty = Disp.text . licenseExceptionId - -instance Parsec LicenseExceptionId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license exception identifier: " ++ n) return $ - mkLicenseExceptionId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseExceptionId where - rnf l = l `seq` () - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseExceptionId :: LicenseExceptionId -> String -licenseExceptionId DS389_exception = "389-exception" -licenseExceptionId Autoconf_exception_2_0 = "Autoconf-exception-2.0" -licenseExceptionId Autoconf_exception_3_0 = "Autoconf-exception-3.0" -licenseExceptionId Bison_exception_2_2 = "Bison-exception-2.2" -licenseExceptionId Bootloader_exception = "Bootloader-exception" -licenseExceptionId Classpath_exception_2_0 = "Classpath-exception-2.0" -licenseExceptionId CLISP_exception_2_0 = "CLISP-exception-2.0" -licenseExceptionId DigiRule_FOSS_exception = "DigiRule-FOSS-exception" -licenseExceptionId ECos_exception_2_0 = "eCos-exception-2.0" -licenseExceptionId Fawkes_Runtime_exception = "Fawkes-Runtime-exception" -licenseExceptionId FLTK_exception = "FLTK-exception" -licenseExceptionId Font_exception_2_0 = "Font-exception-2.0" -licenseExceptionId Freertos_exception_2_0 = "freertos-exception-2.0" -licenseExceptionId GCC_exception_2_0 = "GCC-exception-2.0" -licenseExceptionId GCC_exception_3_1 = "GCC-exception-3.1" -licenseExceptionId Gnu_javamail_exception = "gnu-javamail-exception" -licenseExceptionId GPL_3_0_linking_exception = "GPL-3.0-linking-exception" -licenseExceptionId GPL_3_0_linking_source_exception = "GPL-3.0-linking-source-exception" -licenseExceptionId GPL_CC_1_0 = "GPL-CC-1.0" -licenseExceptionId I2p_gpl_java_exception = "i2p-gpl-java-exception" -licenseExceptionId LGPL_3_0_linking_exception = "LGPL-3.0-linking-exception" -licenseExceptionId Libtool_exception = "Libtool-exception" -licenseExceptionId Linux_syscall_note = "Linux-syscall-note" -licenseExceptionId LLVM_exception = "LLVM-exception" -licenseExceptionId LZMA_exception = "LZMA-exception" -licenseExceptionId Mif_exception = "mif-exception" -licenseExceptionId Nokia_Qt_exception_1_1 = "Nokia-Qt-exception-1.1" -licenseExceptionId OCaml_LGPL_linking_exception = "OCaml-LGPL-linking-exception" -licenseExceptionId OCCT_exception_1_0 = "OCCT-exception-1.0" -licenseExceptionId OpenJDK_assembly_exception_1_0 = "OpenJDK-assembly-exception-1.0" -licenseExceptionId Openvpn_openssl_exception = "openvpn-openssl-exception" -licenseExceptionId PS_or_PDF_font_exception_20170817 = "PS-or-PDF-font-exception-20170817" -licenseExceptionId Qt_GPL_exception_1_0 = "Qt-GPL-exception-1.0" -licenseExceptionId Qt_LGPL_exception_1_1 = "Qt-LGPL-exception-1.1" -licenseExceptionId Qwt_exception_1_0 = "Qwt-exception-1.0" -licenseExceptionId SHL_2_0 = "SHL-2.0" -licenseExceptionId SHL_2_1 = "SHL-2.1" -licenseExceptionId Swift_exception = "Swift-exception" -licenseExceptionId U_boot_exception_2_0 = "u-boot-exception-2.0" -licenseExceptionId Universal_FOSS_exception_1_0 = "Universal-FOSS-exception-1.0" -licenseExceptionId WxWindows_exception_3_1 = "WxWindows-exception-3.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseExceptionName :: LicenseExceptionId -> String -licenseExceptionName DS389_exception = "389 Directory Server Exception" -licenseExceptionName Autoconf_exception_2_0 = "Autoconf exception 2.0" -licenseExceptionName Autoconf_exception_3_0 = "Autoconf exception 3.0" -licenseExceptionName Bison_exception_2_2 = "Bison exception 2.2" -licenseExceptionName Bootloader_exception = "Bootloader Distribution Exception" -licenseExceptionName Classpath_exception_2_0 = "Classpath exception 2.0" -licenseExceptionName CLISP_exception_2_0 = "CLISP exception 2.0" -licenseExceptionName DigiRule_FOSS_exception = "DigiRule FOSS License Exception" -licenseExceptionName ECos_exception_2_0 = "eCos exception 2.0" -licenseExceptionName Fawkes_Runtime_exception = "Fawkes Runtime Exception" -licenseExceptionName FLTK_exception = "FLTK exception" -licenseExceptionName Font_exception_2_0 = "Font exception 2.0" -licenseExceptionName Freertos_exception_2_0 = "FreeRTOS Exception 2.0" -licenseExceptionName GCC_exception_2_0 = "GCC Runtime Library exception 2.0" -licenseExceptionName GCC_exception_3_1 = "GCC Runtime Library exception 3.1" -licenseExceptionName Gnu_javamail_exception = "GNU JavaMail exception" -licenseExceptionName GPL_3_0_linking_exception = "GPL-3.0 Linking Exception" -licenseExceptionName GPL_3_0_linking_source_exception = "GPL-3.0 Linking Exception (with Corresponding Source)" -licenseExceptionName GPL_CC_1_0 = "GPL Cooperation Commitment 1.0" -licenseExceptionName I2p_gpl_java_exception = "i2p GPL+Java Exception" -licenseExceptionName LGPL_3_0_linking_exception = "LGPL-3.0 Linking Exception" -licenseExceptionName Libtool_exception = "Libtool Exception" -licenseExceptionName Linux_syscall_note = "Linux Syscall Note" -licenseExceptionName LLVM_exception = "LLVM Exception" -licenseExceptionName LZMA_exception = "LZMA exception" -licenseExceptionName Mif_exception = "Macros and Inline Functions Exception" -licenseExceptionName Nokia_Qt_exception_1_1 = "Nokia Qt LGPL exception 1.1" -licenseExceptionName OCaml_LGPL_linking_exception = "OCaml LGPL Linking Exception" -licenseExceptionName OCCT_exception_1_0 = "Open CASCADE Exception 1.0" -licenseExceptionName OpenJDK_assembly_exception_1_0 = "OpenJDK Assembly exception 1.0" -licenseExceptionName Openvpn_openssl_exception = "OpenVPN OpenSSL Exception" -licenseExceptionName PS_or_PDF_font_exception_20170817 = "PS/PDF font exception (2017-08-17)" -licenseExceptionName Qt_GPL_exception_1_0 = "Qt GPL exception 1.0" -licenseExceptionName Qt_LGPL_exception_1_1 = "Qt LGPL exception 1.1" -licenseExceptionName Qwt_exception_1_0 = "Qwt exception 1.0" -licenseExceptionName SHL_2_0 = "Solderpad Hardware License v2.0" -licenseExceptionName SHL_2_1 = "Solderpad Hardware License v2.1" -licenseExceptionName Swift_exception = "Swift Exception" -licenseExceptionName U_boot_exception_2_0 = "U-Boot exception 2.0" -licenseExceptionName Universal_FOSS_exception_1_0 = "Universal FOSS Exception, Version 1.0" -licenseExceptionName WxWindows_exception_3_1 = "WxWindows Library Exception 3.1" - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseExceptionIdList :: LicenseListVersion -> [LicenseExceptionId] -licenseExceptionIdList LicenseListVersion_3_0 = - [ Nokia_Qt_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_2 = - [ LLVM_exception - , Nokia_Qt_exception_1_1 - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_6 = - [ GPL_CC_1_0 - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_9 = - [ GPL_3_0_linking_exception - , GPL_3_0_linking_source_exception - , GPL_CC_1_0 - , LGPL_3_0_linking_exception - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , SHL_2_0 - , SHL_2_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses -licenseExceptionIdList LicenseListVersion_3_10 = - [ GPL_3_0_linking_exception - , GPL_3_0_linking_source_exception - , GPL_CC_1_0 - , LGPL_3_0_linking_exception - , LLVM_exception - , OCaml_LGPL_linking_exception - , OpenJDK_assembly_exception_1_0 - , PS_or_PDF_font_exception_20170817 - , Qt_GPL_exception_1_0 - , Qt_LGPL_exception_1_1 - , SHL_2_0 - , SHL_2_1 - , Swift_exception - , Universal_FOSS_exception_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseExceptionId' from a 'String'. -mkLicenseExceptionId :: LicenseListVersion -> String -> Maybe LicenseExceptionId -mkLicenseExceptionId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseExceptionId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseExceptionId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseExceptionId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 -mkLicenseExceptionId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 - -stringLookup_3_0 :: Map String LicenseExceptionId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseExceptionId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseExceptionId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseExceptionId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_9 - -stringLookup_3_10 :: Map String LicenseExceptionId -stringLookup_3_10 = Map.fromList $ map (\i -> (licenseExceptionId i, i)) $ - licenseExceptionIdList LicenseListVersion_3_10 - --- | License exceptions in all SPDX License lists -bulkOfLicenses :: [LicenseExceptionId] -bulkOfLicenses = - [ DS389_exception - , Autoconf_exception_2_0 - , Autoconf_exception_3_0 - , Bison_exception_2_2 - , Bootloader_exception - , Classpath_exception_2_0 - , CLISP_exception_2_0 - , DigiRule_FOSS_exception - , ECos_exception_2_0 - , Fawkes_Runtime_exception - , FLTK_exception - , Font_exception_2_0 - , Freertos_exception_2_0 - , GCC_exception_2_0 - , GCC_exception_3_1 - , Gnu_javamail_exception - , I2p_gpl_java_exception - , Libtool_exception - , Linux_syscall_note - , LZMA_exception - , Mif_exception - , OCCT_exception_1_0 - , Openvpn_openssl_exception - , Qwt_exception_1_0 - , U_boot_exception_2_0 - , WxWindows_exception_3_1 - ] diff --git a/src/Distribution/SPDX/LicenseExpression.hs b/src/Distribution/SPDX/LicenseExpression.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseExpression.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseExpression ( - LicenseExpression (..), - SimpleLicenseExpression (..), - simpleLicenseExpression, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.SPDX.LicenseExceptionId -import Distribution.SPDX.LicenseId -import Distribution.SPDX.LicenseListVersion -import Distribution.SPDX.LicenseReference -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | SPDX License Expression. --- --- @ --- idstring = 1*(ALPHA \/ DIGIT \/ "-" \/ "." ) --- license id = \ --- license exception id = \ --- license ref = [\"DocumentRef-"1*(idstring)":"]\"LicenseRef-"1*(idstring) --- --- simple expression = license id \/ license id"+" \/ license ref --- --- compound expression = 1*1(simple expression \/ --- simple expression \"WITH" license exception id \/ --- compound expression \"AND" compound expression \/ --- compound expression \"OR" compound expression ) \/ --- "(" compound expression ")" ) --- --- license expression = 1*1(simple expression / compound expression) --- @ -data LicenseExpression - = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId) - | EAnd !LicenseExpression !LicenseExpression - | EOr !LicenseExpression !LicenseExpression - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Simple License Expressions. -data SimpleLicenseExpression - = ELicenseId LicenseId - -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@ - | ELicenseIdPlus LicenseId - -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@ - | ELicenseRef LicenseRef - -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@ - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -simpleLicenseExpression :: LicenseId -> LicenseExpression -simpleLicenseExpression i = ELicense (ELicenseId i) Nothing - -instance Binary LicenseExpression -instance Binary SimpleLicenseExpression -instance Structured SimpleLicenseExpression -instance Structured LicenseExpression - -instance Pretty LicenseExpression where - pretty = go 0 - where - go :: Int -> LicenseExpression -> Disp.Doc - go _ (ELicense lic exc) = - let doc = pretty lic - in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc - go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2 - go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2 - - - parens False doc = doc - parens True doc = Disp.parens doc - -instance Pretty SimpleLicenseExpression where - pretty (ELicenseId i) = pretty i - pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+' - pretty (ELicenseRef r) = pretty r - -instance Parsec SimpleLicenseExpression where - parsec = idstring >>= simple where - simple n - | Just l <- "LicenseRef-" `isPrefixOfMaybe` n = - maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l - | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do - _ <- P.string ":LicenseRef-" - l <- idstring - maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l - | otherwise = do - v <- askCabalSpecVersion - l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - orLater <- isJust <$> P.optional (P.char '+') - if orLater - then return (ELicenseIdPlus l) - else return (ELicenseId l) - -idstring :: P.CharParsing m => m String -idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - --- returns suffix part -isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a] -isPrefixOfMaybe pfx s - | pfx `isPrefixOf` s = Just (drop (length pfx) s) - | otherwise = Nothing - -instance Parsec LicenseExpression where - parsec = expr - where - expr = compoundOr - - simple = do - s <- parsec - exc <- exception - return $ ELicense s exc - - exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec - - compoundOr = do - x <- compoundAnd - l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr - return $ maybe id (flip EOr) l x - - compoundAnd = do - x <- compound - l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd - return $ maybe id (flip EAnd) l x - - compound = braces <|> simple - - -- NOTE: we require that there's a space around AND & OR operators, - -- i.e. @(MIT)AND(MIT)@ will cause parse-error. - braces = do - _ <- P.char '(' - _ <- P.spaces - x <- expr - _ <- P.char ')' - return x - - spaces1 = P.space *> P.spaces - --- notes: --- --- There MUST NOT be whitespace between a license­id and any following "+".  This supports easy parsing and --- backwards compatibility.  There MUST be whitespace on either side of the operator "WITH".  There MUST be --- whitespace and/or parentheses on either side of the operators "AND" and "OR". --- --- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier. - -instance NFData LicenseExpression where - rnf (ELicense s e) = rnf s `seq` rnf e - rnf (EAnd x y) = rnf x `seq` rnf y - rnf (EOr x y) = rnf x `seq` rnf y - -instance NFData SimpleLicenseExpression where - rnf (ELicenseId i) = rnf i - rnf (ELicenseIdPlus i) = rnf i - rnf (ELicenseRef r) = rnf r diff --git a/src/Distribution/SPDX/LicenseId.hs b/src/Distribution/SPDX/LicenseId.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseId.hs +++ /dev/null @@ -1,2152 +0,0 @@ --- This file is generated. See Makefile's spdx rule -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseId ( - LicenseId (..), - licenseId, - licenseName, - licenseIsOsiApproved, - licenseIsFsfLibre, - mkLicenseId, - licenseIdList, - -- * Helpers - licenseIdMigrationMessage, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compat.Lens (set) -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion) -import Distribution.SPDX.LicenseListVersion - -import qualified Data.Binary.Get as Binary -import qualified Data.Binary.Put as Binary -import qualified Data.Map.Strict as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- LicenseId -------------------------------------------------------------------------------- - --- | SPDX License identifier -data LicenseId - = NullBSD -- ^ @0BSD@, BSD Zero Clause License - | AAL -- ^ @AAL@, Attribution Assurance License - | Abstyles -- ^ @Abstyles@, Abstyles License - | Adobe_2006 -- ^ @Adobe-2006@, Adobe Systems Incorporated Source Code License Agreement - | Adobe_Glyph -- ^ @Adobe-Glyph@, Adobe Glyph List License - | ADSL -- ^ @ADSL@, Amazon Digital Services License - | AFL_1_1 -- ^ @AFL-1.1@, Academic Free License v1.1 - | AFL_1_2 -- ^ @AFL-1.2@, Academic Free License v1.2 - | AFL_2_0 -- ^ @AFL-2.0@, Academic Free License v2.0 - | AFL_2_1 -- ^ @AFL-2.1@, Academic Free License v2.1 - | AFL_3_0 -- ^ @AFL-3.0@, Academic Free License v3.0 - | Afmparse -- ^ @Afmparse@, Afmparse License - | AGPL_1_0 -- ^ @AGPL-1.0@, Affero General Public License v1.0, SPDX License List 3.0 - | AGPL_1_0_only -- ^ @AGPL-1.0-only@, Affero General Public License v1.0 only, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | AGPL_1_0_or_later -- ^ @AGPL-1.0-or-later@, Affero General Public License v1.0 or later, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | AGPL_3_0_only -- ^ @AGPL-3.0-only@, GNU Affero General Public License v3.0 only - | AGPL_3_0_or_later -- ^ @AGPL-3.0-or-later@, GNU Affero General Public License v3.0 or later - | Aladdin -- ^ @Aladdin@, Aladdin Free Public License - | AMDPLPA -- ^ @AMDPLPA@, AMD's plpa_map.c License - | AML -- ^ @AML@, Apple MIT License - | AMPAS -- ^ @AMPAS@, Academy of Motion Picture Arts and Sciences BSD - | ANTLR_PD -- ^ @ANTLR-PD@, ANTLR Software Rights Notice - | Apache_1_0 -- ^ @Apache-1.0@, Apache License 1.0 - | Apache_1_1 -- ^ @Apache-1.1@, Apache License 1.1 - | Apache_2_0 -- ^ @Apache-2.0@, Apache License 2.0 - | APAFML -- ^ @APAFML@, Adobe Postscript AFM License - | APL_1_0 -- ^ @APL-1.0@, Adaptive Public License 1.0 - | APSL_1_0 -- ^ @APSL-1.0@, Apple Public Source License 1.0 - | APSL_1_1 -- ^ @APSL-1.1@, Apple Public Source License 1.1 - | APSL_1_2 -- ^ @APSL-1.2@, Apple Public Source License 1.2 - | APSL_2_0 -- ^ @APSL-2.0@, Apple Public Source License 2.0 - | Artistic_1_0_cl8 -- ^ @Artistic-1.0-cl8@, Artistic License 1.0 w/clause 8 - | Artistic_1_0_Perl -- ^ @Artistic-1.0-Perl@, Artistic License 1.0 (Perl) - | Artistic_1_0 -- ^ @Artistic-1.0@, Artistic License 1.0 - | Artistic_2_0 -- ^ @Artistic-2.0@, Artistic License 2.0 - | Bahyph -- ^ @Bahyph@, Bahyph License - | Barr -- ^ @Barr@, Barr License - | Beerware -- ^ @Beerware@, Beerware License - | BitTorrent_1_0 -- ^ @BitTorrent-1.0@, BitTorrent Open Source License v1.0 - | BitTorrent_1_1 -- ^ @BitTorrent-1.1@, BitTorrent Open Source License v1.1 - | Blessing -- ^ @blessing@, SQLite Blessing, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | BlueOak_1_0_0 -- ^ @BlueOak-1.0.0@, Blue Oak Model License 1.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Borceux -- ^ @Borceux@, Borceux license - | BSD_1_Clause -- ^ @BSD-1-Clause@, BSD 1-Clause License - | BSD_2_Clause_FreeBSD -- ^ @BSD-2-Clause-FreeBSD@, BSD 2-Clause FreeBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9 - | BSD_2_Clause_NetBSD -- ^ @BSD-2-Clause-NetBSD@, BSD 2-Clause NetBSD License, SPDX License List 3.0, SPDX License List 3.2, SPDX License List 3.6 - | BSD_2_Clause_Patent -- ^ @BSD-2-Clause-Patent@, BSD-2-Clause Plus Patent License - | BSD_2_Clause_Views -- ^ @BSD-2-Clause-Views@, BSD 2-Clause with views sentence, SPDX License List 3.10 - | BSD_2_Clause -- ^ @BSD-2-Clause@, BSD 2-Clause "Simplified" License - | BSD_3_Clause_Attribution -- ^ @BSD-3-Clause-Attribution@, BSD with attribution - | BSD_3_Clause_Clear -- ^ @BSD-3-Clause-Clear@, BSD 3-Clause Clear License - | BSD_3_Clause_LBNL -- ^ @BSD-3-Clause-LBNL@, Lawrence Berkeley National Labs BSD variant license - | BSD_3_Clause_No_Nuclear_License_2014 -- ^ @BSD-3-Clause-No-Nuclear-License-2014@, BSD 3-Clause No Nuclear License 2014 - | BSD_3_Clause_No_Nuclear_License -- ^ @BSD-3-Clause-No-Nuclear-License@, BSD 3-Clause No Nuclear License - | BSD_3_Clause_No_Nuclear_Warranty -- ^ @BSD-3-Clause-No-Nuclear-Warranty@, BSD 3-Clause No Nuclear Warranty - | BSD_3_Clause_Open_MPI -- ^ @BSD-3-Clause-Open-MPI@, BSD 3-Clause Open MPI variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | BSD_3_Clause -- ^ @BSD-3-Clause@, BSD 3-Clause "New" or "Revised" License - | BSD_4_Clause_UC -- ^ @BSD-4-Clause-UC@, BSD-4-Clause (University of California-Specific) - | BSD_4_Clause -- ^ @BSD-4-Clause@, BSD 4-Clause "Original" or "Old" License - | BSD_Protection -- ^ @BSD-Protection@, BSD Protection License - | BSD_Source_Code -- ^ @BSD-Source-Code@, BSD Source Code Attribution - | BSL_1_0 -- ^ @BSL-1.0@, Boost Software License 1.0 - | Bzip2_1_0_5 -- ^ @bzip2-1.0.5@, bzip2 and libbzip2 License v1.0.5 - | Bzip2_1_0_6 -- ^ @bzip2-1.0.6@, bzip2 and libbzip2 License v1.0.6 - | CAL_1_0_Combined_Work_Exception -- ^ @CAL-1.0-Combined-Work-Exception@, Cryptographic Autonomy License 1.0 (Combined Work Exception), SPDX License List 3.9, SPDX License List 3.10 - | CAL_1_0 -- ^ @CAL-1.0@, Cryptographic Autonomy License 1.0, SPDX License List 3.9, SPDX License List 3.10 - | Caldera -- ^ @Caldera@, Caldera License - | CATOSL_1_1 -- ^ @CATOSL-1.1@, Computer Associates Trusted Open Source License 1.1 - | CC_BY_1_0 -- ^ @CC-BY-1.0@, Creative Commons Attribution 1.0 Generic - | CC_BY_2_0 -- ^ @CC-BY-2.0@, Creative Commons Attribution 2.0 Generic - | CC_BY_2_5 -- ^ @CC-BY-2.5@, Creative Commons Attribution 2.5 Generic - | CC_BY_3_0_AT -- ^ @CC-BY-3.0-AT@, Creative Commons Attribution 3.0 Austria, SPDX License List 3.10 - | CC_BY_3_0 -- ^ @CC-BY-3.0@, Creative Commons Attribution 3.0 Unported - | CC_BY_4_0 -- ^ @CC-BY-4.0@, Creative Commons Attribution 4.0 International - | CC_BY_NC_1_0 -- ^ @CC-BY-NC-1.0@, Creative Commons Attribution Non Commercial 1.0 Generic - | CC_BY_NC_2_0 -- ^ @CC-BY-NC-2.0@, Creative Commons Attribution Non Commercial 2.0 Generic - | CC_BY_NC_2_5 -- ^ @CC-BY-NC-2.5@, Creative Commons Attribution Non Commercial 2.5 Generic - | CC_BY_NC_3_0 -- ^ @CC-BY-NC-3.0@, Creative Commons Attribution Non Commercial 3.0 Unported - | CC_BY_NC_4_0 -- ^ @CC-BY-NC-4.0@, Creative Commons Attribution Non Commercial 4.0 International - | CC_BY_NC_ND_1_0 -- ^ @CC-BY-NC-ND-1.0@, Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic - | CC_BY_NC_ND_2_0 -- ^ @CC-BY-NC-ND-2.0@, Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic - | CC_BY_NC_ND_2_5 -- ^ @CC-BY-NC-ND-2.5@, Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic - | CC_BY_NC_ND_3_0_IGO -- ^ @CC-BY-NC-ND-3.0-IGO@, Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO, SPDX License List 3.10 - | CC_BY_NC_ND_3_0 -- ^ @CC-BY-NC-ND-3.0@, Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported - | CC_BY_NC_ND_4_0 -- ^ @CC-BY-NC-ND-4.0@, Creative Commons Attribution Non Commercial No Derivatives 4.0 International - | CC_BY_NC_SA_1_0 -- ^ @CC-BY-NC-SA-1.0@, Creative Commons Attribution Non Commercial Share Alike 1.0 Generic - | CC_BY_NC_SA_2_0 -- ^ @CC-BY-NC-SA-2.0@, Creative Commons Attribution Non Commercial Share Alike 2.0 Generic - | CC_BY_NC_SA_2_5 -- ^ @CC-BY-NC-SA-2.5@, Creative Commons Attribution Non Commercial Share Alike 2.5 Generic - | CC_BY_NC_SA_3_0 -- ^ @CC-BY-NC-SA-3.0@, Creative Commons Attribution Non Commercial Share Alike 3.0 Unported - | CC_BY_NC_SA_4_0 -- ^ @CC-BY-NC-SA-4.0@, Creative Commons Attribution Non Commercial Share Alike 4.0 International - | CC_BY_ND_1_0 -- ^ @CC-BY-ND-1.0@, Creative Commons Attribution No Derivatives 1.0 Generic - | CC_BY_ND_2_0 -- ^ @CC-BY-ND-2.0@, Creative Commons Attribution No Derivatives 2.0 Generic - | CC_BY_ND_2_5 -- ^ @CC-BY-ND-2.5@, Creative Commons Attribution No Derivatives 2.5 Generic - | CC_BY_ND_3_0 -- ^ @CC-BY-ND-3.0@, Creative Commons Attribution No Derivatives 3.0 Unported - | CC_BY_ND_4_0 -- ^ @CC-BY-ND-4.0@, Creative Commons Attribution No Derivatives 4.0 International - | CC_BY_SA_1_0 -- ^ @CC-BY-SA-1.0@, Creative Commons Attribution Share Alike 1.0 Generic - | CC_BY_SA_2_0 -- ^ @CC-BY-SA-2.0@, Creative Commons Attribution Share Alike 2.0 Generic - | CC_BY_SA_2_5 -- ^ @CC-BY-SA-2.5@, Creative Commons Attribution Share Alike 2.5 Generic - | CC_BY_SA_3_0_AT -- ^ @CC-BY-SA-3.0-AT@, Creative Commons Attribution-Share Alike 3.0 Austria, SPDX License List 3.10 - | CC_BY_SA_3_0 -- ^ @CC-BY-SA-3.0@, Creative Commons Attribution Share Alike 3.0 Unported - | CC_BY_SA_4_0 -- ^ @CC-BY-SA-4.0@, Creative Commons Attribution Share Alike 4.0 International - | CC_PDDC -- ^ @CC-PDDC@, Creative Commons Public Domain Dedication and Certification, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CC0_1_0 -- ^ @CC0-1.0@, Creative Commons Zero v1.0 Universal - | CDDL_1_0 -- ^ @CDDL-1.0@, Common Development and Distribution License 1.0 - | CDDL_1_1 -- ^ @CDDL-1.1@, Common Development and Distribution License 1.1 - | CDLA_Permissive_1_0 -- ^ @CDLA-Permissive-1.0@, Community Data License Agreement Permissive 1.0 - | CDLA_Sharing_1_0 -- ^ @CDLA-Sharing-1.0@, Community Data License Agreement Sharing 1.0 - | CECILL_1_0 -- ^ @CECILL-1.0@, CeCILL Free Software License Agreement v1.0 - | CECILL_1_1 -- ^ @CECILL-1.1@, CeCILL Free Software License Agreement v1.1 - | CECILL_2_0 -- ^ @CECILL-2.0@, CeCILL Free Software License Agreement v2.0 - | CECILL_2_1 -- ^ @CECILL-2.1@, CeCILL Free Software License Agreement v2.1 - | CECILL_B -- ^ @CECILL-B@, CeCILL-B Free Software License Agreement - | CECILL_C -- ^ @CECILL-C@, CeCILL-C Free Software License Agreement - | CERN_OHL_1_1 -- ^ @CERN-OHL-1.1@, CERN Open Hardware Licence v1.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_1_2 -- ^ @CERN-OHL-1.2@, CERN Open Hardware Licence v1.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_P_2_0 -- ^ @CERN-OHL-P-2.0@, CERN Open Hardware Licence Version 2 - Permissive, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_S_2_0 -- ^ @CERN-OHL-S-2.0@, CERN Open Hardware Licence Version 2 - Strongly Reciprocal, SPDX License List 3.9, SPDX License List 3.10 - | CERN_OHL_W_2_0 -- ^ @CERN-OHL-W-2.0@, CERN Open Hardware Licence Version 2 - Weakly Reciprocal, SPDX License List 3.9, SPDX License List 3.10 - | ClArtistic -- ^ @ClArtistic@, Clarified Artistic License - | CNRI_Jython -- ^ @CNRI-Jython@, CNRI Jython License - | CNRI_Python_GPL_Compatible -- ^ @CNRI-Python-GPL-Compatible@, CNRI Python Open Source GPL Compatible License Agreement - | CNRI_Python -- ^ @CNRI-Python@, CNRI Python License - | Condor_1_1 -- ^ @Condor-1.1@, Condor Public License v1.1 - | Copyleft_next_0_3_0 -- ^ @copyleft-next-0.3.0@, copyleft-next 0.3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Copyleft_next_0_3_1 -- ^ @copyleft-next-0.3.1@, copyleft-next 0.3.1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | CPAL_1_0 -- ^ @CPAL-1.0@, Common Public Attribution License 1.0 - | CPL_1_0 -- ^ @CPL-1.0@, Common Public License 1.0 - | CPOL_1_02 -- ^ @CPOL-1.02@, Code Project Open License 1.02 - | Crossword -- ^ @Crossword@, Crossword License - | CrystalStacker -- ^ @CrystalStacker@, CrystalStacker License - | CUA_OPL_1_0 -- ^ @CUA-OPL-1.0@, CUA Office Public License v1.0 - | Cube -- ^ @Cube@, Cube License - | Curl -- ^ @curl@, curl License - | D_FSL_1_0 -- ^ @D-FSL-1.0@, Deutsche Freie Software Lizenz - | Diffmark -- ^ @diffmark@, diffmark license - | DOC -- ^ @DOC@, DOC License - | Dotseqn -- ^ @Dotseqn@, Dotseqn License - | DSDP -- ^ @DSDP@, DSDP License - | Dvipdfm -- ^ @dvipdfm@, dvipdfm License - | ECL_1_0 -- ^ @ECL-1.0@, Educational Community License v1.0 - | ECL_2_0 -- ^ @ECL-2.0@, Educational Community License v2.0 - | EFL_1_0 -- ^ @EFL-1.0@, Eiffel Forum License v1.0 - | EFL_2_0 -- ^ @EFL-2.0@, Eiffel Forum License v2.0 - | EGenix -- ^ @eGenix@, eGenix.com Public License 1.1.0 - | Entessa -- ^ @Entessa@, Entessa Public License v1.0 - | EPICS -- ^ @EPICS@, EPICS Open License, SPDX License List 3.10 - | EPL_1_0 -- ^ @EPL-1.0@, Eclipse Public License 1.0 - | EPL_2_0 -- ^ @EPL-2.0@, Eclipse Public License 2.0 - | ErlPL_1_1 -- ^ @ErlPL-1.1@, Erlang Public License v1.1 - | Etalab_2_0 -- ^ @etalab-2.0@, Etalab Open License 2.0, SPDX License List 3.9, SPDX License List 3.10 - | EUDatagrid -- ^ @EUDatagrid@, EU DataGrid Software License - | EUPL_1_0 -- ^ @EUPL-1.0@, European Union Public License 1.0 - | EUPL_1_1 -- ^ @EUPL-1.1@, European Union Public License 1.1 - | EUPL_1_2 -- ^ @EUPL-1.2@, European Union Public License 1.2 - | Eurosym -- ^ @Eurosym@, Eurosym License - | Fair -- ^ @Fair@, Fair License - | Frameworx_1_0 -- ^ @Frameworx-1.0@, Frameworx Open License 1.0 - | FreeImage -- ^ @FreeImage@, FreeImage Public License v1.0 - | FSFAP -- ^ @FSFAP@, FSF All Permissive License - | FSFULLR -- ^ @FSFULLR@, FSF Unlimited License (with License Retention) - | FSFUL -- ^ @FSFUL@, FSF Unlimited License - | FTL -- ^ @FTL@, Freetype Project License - | GFDL_1_1_invariants_only -- ^ @GFDL-1.1-invariants-only@, GNU Free Documentation License v1.1 only - invariants, SPDX License List 3.10 - | GFDL_1_1_invariants_or_later -- ^ @GFDL-1.1-invariants-or-later@, GNU Free Documentation License v1.1 or later - invariants, SPDX License List 3.10 - | GFDL_1_1_no_invariants_only -- ^ @GFDL-1.1-no-invariants-only@, GNU Free Documentation License v1.1 only - no invariants, SPDX License List 3.10 - | GFDL_1_1_no_invariants_or_later -- ^ @GFDL-1.1-no-invariants-or-later@, GNU Free Documentation License v1.1 or later - no invariants, SPDX License List 3.10 - | GFDL_1_1_only -- ^ @GFDL-1.1-only@, GNU Free Documentation License v1.1 only - | GFDL_1_1_or_later -- ^ @GFDL-1.1-or-later@, GNU Free Documentation License v1.1 or later - | GFDL_1_2_invariants_only -- ^ @GFDL-1.2-invariants-only@, GNU Free Documentation License v1.2 only - invariants, SPDX License List 3.10 - | GFDL_1_2_invariants_or_later -- ^ @GFDL-1.2-invariants-or-later@, GNU Free Documentation License v1.2 or later - invariants, SPDX License List 3.10 - | GFDL_1_2_no_invariants_only -- ^ @GFDL-1.2-no-invariants-only@, GNU Free Documentation License v1.2 only - no invariants, SPDX License List 3.10 - | GFDL_1_2_no_invariants_or_later -- ^ @GFDL-1.2-no-invariants-or-later@, GNU Free Documentation License v1.2 or later - no invariants, SPDX License List 3.10 - | GFDL_1_2_only -- ^ @GFDL-1.2-only@, GNU Free Documentation License v1.2 only - | GFDL_1_2_or_later -- ^ @GFDL-1.2-or-later@, GNU Free Documentation License v1.2 or later - | GFDL_1_3_invariants_only -- ^ @GFDL-1.3-invariants-only@, GNU Free Documentation License v1.3 only - invariants, SPDX License List 3.10 - | GFDL_1_3_invariants_or_later -- ^ @GFDL-1.3-invariants-or-later@, GNU Free Documentation License v1.3 or later - invariants, SPDX License List 3.10 - | GFDL_1_3_no_invariants_only -- ^ @GFDL-1.3-no-invariants-only@, GNU Free Documentation License v1.3 only - no invariants, SPDX License List 3.10 - | GFDL_1_3_no_invariants_or_later -- ^ @GFDL-1.3-no-invariants-or-later@, GNU Free Documentation License v1.3 or later - no invariants, SPDX License List 3.10 - | GFDL_1_3_only -- ^ @GFDL-1.3-only@, GNU Free Documentation License v1.3 only - | GFDL_1_3_or_later -- ^ @GFDL-1.3-or-later@, GNU Free Documentation License v1.3 or later - | Giftware -- ^ @Giftware@, Giftware License - | GL2PS -- ^ @GL2PS@, GL2PS License - | Glide -- ^ @Glide@, 3dfx Glide License - | Glulxe -- ^ @Glulxe@, Glulxe License - | GLWTPL -- ^ @GLWTPL@, Good Luck With That Public License, SPDX License List 3.10 - | Gnuplot -- ^ @gnuplot@, gnuplot License - | GPL_1_0_only -- ^ @GPL-1.0-only@, GNU General Public License v1.0 only - | GPL_1_0_or_later -- ^ @GPL-1.0-or-later@, GNU General Public License v1.0 or later - | GPL_2_0_only -- ^ @GPL-2.0-only@, GNU General Public License v2.0 only - | GPL_2_0_or_later -- ^ @GPL-2.0-or-later@, GNU General Public License v2.0 or later - | GPL_3_0_only -- ^ @GPL-3.0-only@, GNU General Public License v3.0 only - | GPL_3_0_or_later -- ^ @GPL-3.0-or-later@, GNU General Public License v3.0 or later - | GSOAP_1_3b -- ^ @gSOAP-1.3b@, gSOAP Public License v1.3b - | HaskellReport -- ^ @HaskellReport@, Haskell Language Report License - | Hippocratic_2_1 -- ^ @Hippocratic-2.1@, Hippocratic License 2.1, SPDX License List 3.9, SPDX License List 3.10 - | HPND_sell_variant -- ^ @HPND-sell-variant@, Historical Permission Notice and Disclaimer - sell variant, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | HPND -- ^ @HPND@, Historical Permission Notice and Disclaimer - | IBM_pibs -- ^ @IBM-pibs@, IBM PowerPC Initialization and Boot Software - | ICU -- ^ @ICU@, ICU License - | IJG -- ^ @IJG@, Independent JPEG Group License - | ImageMagick -- ^ @ImageMagick@, ImageMagick License - | IMatix -- ^ @iMatix@, iMatix Standard Function Library Agreement - | Imlib2 -- ^ @Imlib2@, Imlib2 License - | Info_ZIP -- ^ @Info-ZIP@, Info-ZIP License - | Intel_ACPI -- ^ @Intel-ACPI@, Intel ACPI Software License Agreement - | Intel -- ^ @Intel@, Intel Open Source License - | Interbase_1_0 -- ^ @Interbase-1.0@, Interbase Public License v1.0 - | IPA -- ^ @IPA@, IPA Font License - | IPL_1_0 -- ^ @IPL-1.0@, IBM Public License v1.0 - | ISC -- ^ @ISC@, ISC License - | JasPer_2_0 -- ^ @JasPer-2.0@, JasPer License - | JPNIC -- ^ @JPNIC@, Japan Network Information Center License, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | JSON -- ^ @JSON@, JSON License - | LAL_1_2 -- ^ @LAL-1.2@, Licence Art Libre 1.2 - | LAL_1_3 -- ^ @LAL-1.3@, Licence Art Libre 1.3 - | Latex2e -- ^ @Latex2e@, Latex2e License - | Leptonica -- ^ @Leptonica@, Leptonica License - | LGPL_2_0_only -- ^ @LGPL-2.0-only@, GNU Library General Public License v2 only - | LGPL_2_0_or_later -- ^ @LGPL-2.0-or-later@, GNU Library General Public License v2 or later - | LGPL_2_1_only -- ^ @LGPL-2.1-only@, GNU Lesser General Public License v2.1 only - | LGPL_2_1_or_later -- ^ @LGPL-2.1-or-later@, GNU Lesser General Public License v2.1 or later - | LGPL_3_0_only -- ^ @LGPL-3.0-only@, GNU Lesser General Public License v3.0 only - | LGPL_3_0_or_later -- ^ @LGPL-3.0-or-later@, GNU Lesser General Public License v3.0 or later - | LGPLLR -- ^ @LGPLLR@, Lesser General Public License For Linguistic Resources - | Libpng_2_0 -- ^ @libpng-2.0@, PNG Reference Library version 2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Libpng -- ^ @Libpng@, libpng License - | Libselinux_1_0 -- ^ @libselinux-1.0@, libselinux public domain notice, SPDX License List 3.9, SPDX License List 3.10 - | Libtiff -- ^ @libtiff@, libtiff License - | LiLiQ_P_1_1 -- ^ @LiLiQ-P-1.1@, Licence Libre du Québec – Permissive version 1.1 - | LiLiQ_R_1_1 -- ^ @LiLiQ-R-1.1@, Licence Libre du Québec – Réciprocité version 1.1 - | LiLiQ_Rplus_1_1 -- ^ @LiLiQ-Rplus-1.1@, Licence Libre du Québec – Réciprocité forte version 1.1 - | Linux_OpenIB -- ^ @Linux-OpenIB@, Linux Kernel Variant of OpenIB.org license, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | LPL_1_02 -- ^ @LPL-1.02@, Lucent Public License v1.02 - | LPL_1_0 -- ^ @LPL-1.0@, Lucent Public License Version 1.0 - | LPPL_1_0 -- ^ @LPPL-1.0@, LaTeX Project Public License v1.0 - | LPPL_1_1 -- ^ @LPPL-1.1@, LaTeX Project Public License v1.1 - | LPPL_1_2 -- ^ @LPPL-1.2@, LaTeX Project Public License v1.2 - | LPPL_1_3a -- ^ @LPPL-1.3a@, LaTeX Project Public License v1.3a - | LPPL_1_3c -- ^ @LPPL-1.3c@, LaTeX Project Public License v1.3c - | MakeIndex -- ^ @MakeIndex@, MakeIndex License - | MirOS -- ^ @MirOS@, The MirOS Licence - | MIT_0 -- ^ @MIT-0@, MIT No Attribution, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | MIT_advertising -- ^ @MIT-advertising@, Enlightenment License (e16) - | MIT_CMU -- ^ @MIT-CMU@, CMU License - | MIT_enna -- ^ @MIT-enna@, enna License - | MIT_feh -- ^ @MIT-feh@, feh License - | MITNFA -- ^ @MITNFA@, MIT +no-false-attribs license - | MIT -- ^ @MIT@, MIT License - | Motosoto -- ^ @Motosoto@, Motosoto License - | Mpich2 -- ^ @mpich2@, mpich2 License - | MPL_1_0 -- ^ @MPL-1.0@, Mozilla Public License 1.0 - | MPL_1_1 -- ^ @MPL-1.1@, Mozilla Public License 1.1 - | MPL_2_0_no_copyleft_exception -- ^ @MPL-2.0-no-copyleft-exception@, Mozilla Public License 2.0 (no copyleft exception) - | MPL_2_0 -- ^ @MPL-2.0@, Mozilla Public License 2.0 - | MS_PL -- ^ @MS-PL@, Microsoft Public License - | MS_RL -- ^ @MS-RL@, Microsoft Reciprocal License - | MTLL -- ^ @MTLL@, Matrix Template Library License - | MulanPSL_1_0 -- ^ @MulanPSL-1.0@, Mulan Permissive Software License, Version 1, SPDX License List 3.9, SPDX License List 3.10 - | MulanPSL_2_0 -- ^ @MulanPSL-2.0@, Mulan Permissive Software License, Version 2, SPDX License List 3.9, SPDX License List 3.10 - | Multics -- ^ @Multics@, Multics License - | Mup -- ^ @Mup@, Mup License - | NASA_1_3 -- ^ @NASA-1.3@, NASA Open Source Agreement 1.3 - | Naumen -- ^ @Naumen@, Naumen Public License - | NBPL_1_0 -- ^ @NBPL-1.0@, Net Boolean Public License v1 - | NCGL_UK_2_0 -- ^ @NCGL-UK-2.0@, Non-Commercial Government Licence, SPDX License List 3.9, SPDX License List 3.10 - | NCSA -- ^ @NCSA@, University of Illinois/NCSA Open Source License - | Net_SNMP -- ^ @Net-SNMP@, Net-SNMP License - | NetCDF -- ^ @NetCDF@, NetCDF license - | Newsletr -- ^ @Newsletr@, Newsletr License - | NGPL -- ^ @NGPL@, Nethack General Public License - | NIST_PD_fallback -- ^ @NIST-PD-fallback@, NIST Public Domain Notice with license fallback, SPDX License List 3.10 - | NIST_PD -- ^ @NIST-PD@, NIST Public Domain Notice, SPDX License List 3.10 - | NLOD_1_0 -- ^ @NLOD-1.0@, Norwegian Licence for Open Government Data - | NLPL -- ^ @NLPL@, No Limit Public License - | Nokia -- ^ @Nokia@, Nokia Open Source License - | NOSL -- ^ @NOSL@, Netizen Open Source License - | Noweb -- ^ @Noweb@, Noweb License - | NPL_1_0 -- ^ @NPL-1.0@, Netscape Public License v1.0 - | NPL_1_1 -- ^ @NPL-1.1@, Netscape Public License v1.1 - | NPOSL_3_0 -- ^ @NPOSL-3.0@, Non-Profit Open Software License 3.0 - | NRL -- ^ @NRL@, NRL License - | NTP_0 -- ^ @NTP-0@, NTP No Attribution, SPDX License List 3.9, SPDX License List 3.10 - | NTP -- ^ @NTP@, NTP License - | O_UDA_1_0 -- ^ @O-UDA-1.0@, Open Use of Data Agreement v1.0, SPDX License List 3.9, SPDX License List 3.10 - | OCCT_PL -- ^ @OCCT-PL@, Open CASCADE Technology Public License - | OCLC_2_0 -- ^ @OCLC-2.0@, OCLC Research Public License 2.0 - | ODbL_1_0 -- ^ @ODbL-1.0@, ODC Open Database License v1.0 - | ODC_By_1_0 -- ^ @ODC-By-1.0@, Open Data Commons Attribution License v1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0_no_RFN -- ^ @OFL-1.0-no-RFN@, SIL Open Font License 1.0 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0_RFN -- ^ @OFL-1.0-RFN@, SIL Open Font License 1.0 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_0 -- ^ @OFL-1.0@, SIL Open Font License 1.0 - | OFL_1_1_no_RFN -- ^ @OFL-1.1-no-RFN@, SIL Open Font License 1.1 with no Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_1_RFN -- ^ @OFL-1.1-RFN@, SIL Open Font License 1.1 with Reserved Font Name, SPDX License List 3.9, SPDX License List 3.10 - | OFL_1_1 -- ^ @OFL-1.1@, SIL Open Font License 1.1 - | OGC_1_0 -- ^ @OGC-1.0@, OGC Software License, Version 1.0, SPDX License List 3.9, SPDX License List 3.10 - | OGL_Canada_2_0 -- ^ @OGL-Canada-2.0@, Open Government Licence - Canada, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_1_0 -- ^ @OGL-UK-1.0@, Open Government Licence v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_2_0 -- ^ @OGL-UK-2.0@, Open Government Licence v2.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGL_UK_3_0 -- ^ @OGL-UK-3.0@, Open Government Licence v3.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | OGTSL -- ^ @OGTSL@, Open Group Test Suite License - | OLDAP_1_1 -- ^ @OLDAP-1.1@, Open LDAP Public License v1.1 - | OLDAP_1_2 -- ^ @OLDAP-1.2@, Open LDAP Public License v1.2 - | OLDAP_1_3 -- ^ @OLDAP-1.3@, Open LDAP Public License v1.3 - | OLDAP_1_4 -- ^ @OLDAP-1.4@, Open LDAP Public License v1.4 - | OLDAP_2_0_1 -- ^ @OLDAP-2.0.1@, Open LDAP Public License v2.0.1 - | OLDAP_2_0 -- ^ @OLDAP-2.0@, Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B) - | OLDAP_2_1 -- ^ @OLDAP-2.1@, Open LDAP Public License v2.1 - | OLDAP_2_2_1 -- ^ @OLDAP-2.2.1@, Open LDAP Public License v2.2.1 - | OLDAP_2_2_2 -- ^ @OLDAP-2.2.2@, Open LDAP Public License 2.2.2 - | OLDAP_2_2 -- ^ @OLDAP-2.2@, Open LDAP Public License v2.2 - | OLDAP_2_3 -- ^ @OLDAP-2.3@, Open LDAP Public License v2.3 - | OLDAP_2_4 -- ^ @OLDAP-2.4@, Open LDAP Public License v2.4 - | OLDAP_2_5 -- ^ @OLDAP-2.5@, Open LDAP Public License v2.5 - | OLDAP_2_6 -- ^ @OLDAP-2.6@, Open LDAP Public License v2.6 - | OLDAP_2_7 -- ^ @OLDAP-2.7@, Open LDAP Public License v2.7 - | OLDAP_2_8 -- ^ @OLDAP-2.8@, Open LDAP Public License v2.8 - | OML -- ^ @OML@, Open Market License - | OpenSSL -- ^ @OpenSSL@, OpenSSL License - | OPL_1_0 -- ^ @OPL-1.0@, Open Public License v1.0 - | OSET_PL_2_1 -- ^ @OSET-PL-2.1@, OSET Public License version 2.1 - | OSL_1_0 -- ^ @OSL-1.0@, Open Software License 1.0 - | OSL_1_1 -- ^ @OSL-1.1@, Open Software License 1.1 - | OSL_2_0 -- ^ @OSL-2.0@, Open Software License 2.0 - | OSL_2_1 -- ^ @OSL-2.1@, Open Software License 2.1 - | OSL_3_0 -- ^ @OSL-3.0@, Open Software License 3.0 - | Parity_6_0_0 -- ^ @Parity-6.0.0@, The Parity Public License 6.0.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Parity_7_0_0 -- ^ @Parity-7.0.0@, The Parity Public License 7.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PDDL_1_0 -- ^ @PDDL-1.0@, ODC Public Domain Dedication & License 1.0 - | PHP_3_01 -- ^ @PHP-3.01@, PHP License v3.01 - | PHP_3_0 -- ^ @PHP-3.0@, PHP License v3.0 - | Plexus -- ^ @Plexus@, Plexus Classworlds License - | PolyForm_Noncommercial_1_0_0 -- ^ @PolyForm-Noncommercial-1.0.0@, PolyForm Noncommercial License 1.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PolyForm_Small_Business_1_0_0 -- ^ @PolyForm-Small-Business-1.0.0@, PolyForm Small Business License 1.0.0, SPDX License List 3.9, SPDX License List 3.10 - | PostgreSQL -- ^ @PostgreSQL@, PostgreSQL License - | PSF_2_0 -- ^ @PSF-2.0@, Python Software Foundation License 2.0, SPDX License List 3.9, SPDX License List 3.10 - | Psfrag -- ^ @psfrag@, psfrag License - | Psutils -- ^ @psutils@, psutils License - | Python_2_0 -- ^ @Python-2.0@, Python License 2.0 - | Qhull -- ^ @Qhull@, Qhull License - | QPL_1_0 -- ^ @QPL-1.0@, Q Public License 1.0 - | Rdisc -- ^ @Rdisc@, Rdisc License - | RHeCos_1_1 -- ^ @RHeCos-1.1@, Red Hat eCos Public License v1.1 - | RPL_1_1 -- ^ @RPL-1.1@, Reciprocal Public License 1.1 - | RPL_1_5 -- ^ @RPL-1.5@, Reciprocal Public License 1.5 - | RPSL_1_0 -- ^ @RPSL-1.0@, RealNetworks Public Source License v1.0 - | RSA_MD -- ^ @RSA-MD@, RSA Message-Digest License - | RSCPL -- ^ @RSCPL@, Ricoh Source Code Public License - | Ruby -- ^ @Ruby@, Ruby License - | SAX_PD -- ^ @SAX-PD@, Sax Public Domain Notice - | Saxpath -- ^ @Saxpath@, Saxpath License - | SCEA -- ^ @SCEA@, SCEA Shared Source License - | Sendmail_8_23 -- ^ @Sendmail-8.23@, Sendmail License 8.23, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | Sendmail -- ^ @Sendmail@, Sendmail License - | SGI_B_1_0 -- ^ @SGI-B-1.0@, SGI Free Software License B v1.0 - | SGI_B_1_1 -- ^ @SGI-B-1.1@, SGI Free Software License B v1.1 - | SGI_B_2_0 -- ^ @SGI-B-2.0@, SGI Free Software License B v2.0 - | SHL_0_51 -- ^ @SHL-0.51@, Solderpad Hardware License, Version 0.51, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SHL_0_5 -- ^ @SHL-0.5@, Solderpad Hardware License v0.5, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SimPL_2_0 -- ^ @SimPL-2.0@, Simple Public License 2.0 - | SISSL_1_2 -- ^ @SISSL-1.2@, Sun Industry Standards Source License v1.2 - | SISSL -- ^ @SISSL@, Sun Industry Standards Source License v1.1 - | Sleepycat -- ^ @Sleepycat@, Sleepycat License - | SMLNJ -- ^ @SMLNJ@, Standard ML of New Jersey License - | SMPPL -- ^ @SMPPL@, Secure Messaging Protocol Public License - | SNIA -- ^ @SNIA@, SNIA Public License 1.1 - | Spencer_86 -- ^ @Spencer-86@, Spencer License 86 - | Spencer_94 -- ^ @Spencer-94@, Spencer License 94 - | Spencer_99 -- ^ @Spencer-99@, Spencer License 99 - | SPL_1_0 -- ^ @SPL-1.0@, Sun Public License v1.0 - | SSH_OpenSSH -- ^ @SSH-OpenSSH@, SSH OpenSSH license, SPDX License List 3.9, SPDX License List 3.10 - | SSH_short -- ^ @SSH-short@, SSH short notice, SPDX License List 3.9, SPDX License List 3.10 - | SSPL_1_0 -- ^ @SSPL-1.0@, Server Side Public License, v 1, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | SugarCRM_1_1_3 -- ^ @SugarCRM-1.1.3@, SugarCRM Public License v1.1.3 - | SWL -- ^ @SWL@, Scheme Widget Library (SWL) Software License Agreement - | TAPR_OHL_1_0 -- ^ @TAPR-OHL-1.0@, TAPR Open Hardware License v1.0, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | TCL -- ^ @TCL@, TCL/TK License - | TCP_wrappers -- ^ @TCP-wrappers@, TCP Wrappers License - | TMate -- ^ @TMate@, TMate Open Source License - | TORQUE_1_1 -- ^ @TORQUE-1.1@, TORQUE v2.5+ Software License v1.1 - | TOSL -- ^ @TOSL@, Trusster Open Source License - | TU_Berlin_1_0 -- ^ @TU-Berlin-1.0@, Technische Universitaet Berlin License 1.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | TU_Berlin_2_0 -- ^ @TU-Berlin-2.0@, Technische Universitaet Berlin License 2.0, SPDX License List 3.2, SPDX License List 3.6, SPDX License List 3.9, SPDX License List 3.10 - | UCL_1_0 -- ^ @UCL-1.0@, Upstream Compatibility License v1.0, SPDX License List 3.9, SPDX License List 3.10 - | Unicode_DFS_2015 -- ^ @Unicode-DFS-2015@, Unicode License Agreement - Data Files and Software (2015) - | Unicode_DFS_2016 -- ^ @Unicode-DFS-2016@, Unicode License Agreement - Data Files and Software (2016) - | Unicode_TOU -- ^ @Unicode-TOU@, Unicode Terms of Use - | Unlicense -- ^ @Unlicense@, The Unlicense - | UPL_1_0 -- ^ @UPL-1.0@, Universal Permissive License v1.0 - | Vim -- ^ @Vim@, Vim License - | VOSTROM -- ^ @VOSTROM@, VOSTROM Public License for Open Source - | VSL_1_0 -- ^ @VSL-1.0@, Vovida Software License v1.0 - | W3C_19980720 -- ^ @W3C-19980720@, W3C Software Notice and License (1998-07-20) - | W3C_20150513 -- ^ @W3C-20150513@, W3C Software Notice and Document License (2015-05-13) - | W3C -- ^ @W3C@, W3C Software Notice and License (2002-12-31) - | Watcom_1_0 -- ^ @Watcom-1.0@, Sybase Open Watcom Public License 1.0 - | Wsuipa -- ^ @Wsuipa@, Wsuipa License - | WTFPL -- ^ @WTFPL@, Do What The F*ck You Want To Public License - | X11 -- ^ @X11@, X11 License - | Xerox -- ^ @Xerox@, Xerox License - | XFree86_1_1 -- ^ @XFree86-1.1@, XFree86 License 1.1 - | Xinetd -- ^ @xinetd@, xinetd License - | Xnet -- ^ @Xnet@, X.Net License - | Xpp -- ^ @xpp@, XPP License - | XSkat -- ^ @XSkat@, XSkat License - | YPL_1_0 -- ^ @YPL-1.0@, Yahoo! Public License v1.0 - | YPL_1_1 -- ^ @YPL-1.1@, Yahoo! Public License v1.1 - | Zed -- ^ @Zed@, Zed License - | Zend_2_0 -- ^ @Zend-2.0@, Zend License v2.0 - | Zimbra_1_3 -- ^ @Zimbra-1.3@, Zimbra Public License v1.3 - | Zimbra_1_4 -- ^ @Zimbra-1.4@, Zimbra Public License v1.4 - | Zlib_acknowledgement -- ^ @zlib-acknowledgement@, zlib/libpng License with Acknowledgement - | Zlib -- ^ @Zlib@, zlib License - | ZPL_1_1 -- ^ @ZPL-1.1@, Zope Public License 1.1 - | ZPL_2_0 -- ^ @ZPL-2.0@, Zope Public License 2.0 - | ZPL_2_1 -- ^ @ZPL-2.1@, Zope Public License 2.1 - deriving (Eq, Ord, Enum, Bounded, Show, Read, Typeable, Data, Generic) - -instance Binary LicenseId where - -- Word16 is encoded in big endianess - -- https://github.com/kolmodin/binary/blob/master/src/Data/Binary/Class.hs#L220-LL227 - put = Binary.putWord16be . fromIntegral . fromEnum - get = do - i <- Binary.getWord16be - if i > fromIntegral (fromEnum (maxBound :: LicenseId)) - then fail "Too large LicenseId tag" - else return (toEnum (fromIntegral i)) - --- note: remember to bump version each time the definition changes -instance Structured LicenseId where - structure p = set typeVersion 306 $ nominalStructure p - -instance Pretty LicenseId where - pretty = Disp.text . licenseId - --- | --- >>> eitherParsec "BSD-3-Clause" :: Either String LicenseId --- Right BSD_3_Clause --- --- >>> eitherParsec "BSD3" :: Either String LicenseId --- Left "...Unknown SPDX license identifier: 'BSD3' Do you mean BSD-3-Clause?" --- -instance Parsec LicenseId where - parsec = do - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - v <- askCabalSpecVersion - maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $ - mkLicenseId (cabalSpecVersionToSPDXListVersion v) n - -instance NFData LicenseId where - rnf l = l `seq` () - --- | Help message for migrating from non-SPDX license identifiers. --- --- Old 'License' is almost SPDX, except for 'BSD2', 'BSD3'. This function --- suggests SPDX variant: --- --- >>> licenseIdMigrationMessage "BSD3" --- "Do you mean BSD-3-Clause?" --- --- Also 'OtherLicense', 'AllRightsReserved', and 'PublicDomain' aren't --- valid SPDX identifiers --- --- >>> traverse_ (print . licenseIdMigrationMessage) [ "OtherLicense", "AllRightsReserved", "PublicDomain" ] --- "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." --- "You can use NONE as a value of license field." --- "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." --- --- SPDX License list version 3.0 introduced "-only" and "-or-later" variants for GNU family of licenses. --- See --- >>> licenseIdMigrationMessage "GPL-2.0" --- "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use GPL-2.0-only or GPL-2.0-or-later." --- --- For other common licenses their old license format coincides with the SPDX identifiers: --- --- >>> traverse eitherParsec ["GPL-2.0-only", "GPL-3.0-only", "LGPL-2.1-only", "MIT", "ISC", "MPL-2.0", "Apache-2.0"] :: Either String [LicenseId] --- Right [GPL_2_0_only,GPL_3_0_only,LGPL_2_1_only,MIT,ISC,MPL_2_0,Apache_2_0] --- -licenseIdMigrationMessage :: String -> String -licenseIdMigrationMessage = go where - go l | gnuVariant l = "SPDX license list 3.0 deprecated suffixless variants of GNU family of licenses. Use " ++ l ++ "-only or " ++ l ++ "-or-later." - go "BSD3" = "Do you mean BSD-3-Clause?" - go "BSD2" = "Do you mean BSD-2-Clause?" - go "AllRightsReserved" = "You can use NONE as a value of license field." - go "OtherLicense" = "SPDX license list contains plenty of licenses. See https://spdx.org/licenses/. Also they can be combined into complex expressions with AND and OR." - go "PublicDomain" = "Public Domain is a complex matter. See https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files. Consider using a proper license." - - -- otherwise, we don't know - go _ = "" - - gnuVariant = flip elem ["GPL-2.0", "GPL-3.0", "LGPL-2.1", "LGPL-3.0", "AGPL-3.0" ] - -------------------------------------------------------------------------------- --- License Data -------------------------------------------------------------------------------- - --- | License SPDX identifier, e.g. @"BSD-3-Clause"@. -licenseId :: LicenseId -> String -licenseId NullBSD = "0BSD" -licenseId AAL = "AAL" -licenseId Abstyles = "Abstyles" -licenseId Adobe_2006 = "Adobe-2006" -licenseId Adobe_Glyph = "Adobe-Glyph" -licenseId ADSL = "ADSL" -licenseId AFL_1_1 = "AFL-1.1" -licenseId AFL_1_2 = "AFL-1.2" -licenseId AFL_2_0 = "AFL-2.0" -licenseId AFL_2_1 = "AFL-2.1" -licenseId AFL_3_0 = "AFL-3.0" -licenseId Afmparse = "Afmparse" -licenseId AGPL_1_0 = "AGPL-1.0" -licenseId AGPL_1_0_only = "AGPL-1.0-only" -licenseId AGPL_1_0_or_later = "AGPL-1.0-or-later" -licenseId AGPL_3_0_only = "AGPL-3.0-only" -licenseId AGPL_3_0_or_later = "AGPL-3.0-or-later" -licenseId Aladdin = "Aladdin" -licenseId AMDPLPA = "AMDPLPA" -licenseId AML = "AML" -licenseId AMPAS = "AMPAS" -licenseId ANTLR_PD = "ANTLR-PD" -licenseId Apache_1_0 = "Apache-1.0" -licenseId Apache_1_1 = "Apache-1.1" -licenseId Apache_2_0 = "Apache-2.0" -licenseId APAFML = "APAFML" -licenseId APL_1_0 = "APL-1.0" -licenseId APSL_1_0 = "APSL-1.0" -licenseId APSL_1_1 = "APSL-1.1" -licenseId APSL_1_2 = "APSL-1.2" -licenseId APSL_2_0 = "APSL-2.0" -licenseId Artistic_1_0_cl8 = "Artistic-1.0-cl8" -licenseId Artistic_1_0_Perl = "Artistic-1.0-Perl" -licenseId Artistic_1_0 = "Artistic-1.0" -licenseId Artistic_2_0 = "Artistic-2.0" -licenseId Bahyph = "Bahyph" -licenseId Barr = "Barr" -licenseId Beerware = "Beerware" -licenseId BitTorrent_1_0 = "BitTorrent-1.0" -licenseId BitTorrent_1_1 = "BitTorrent-1.1" -licenseId Blessing = "blessing" -licenseId BlueOak_1_0_0 = "BlueOak-1.0.0" -licenseId Borceux = "Borceux" -licenseId BSD_1_Clause = "BSD-1-Clause" -licenseId BSD_2_Clause_FreeBSD = "BSD-2-Clause-FreeBSD" -licenseId BSD_2_Clause_NetBSD = "BSD-2-Clause-NetBSD" -licenseId BSD_2_Clause_Patent = "BSD-2-Clause-Patent" -licenseId BSD_2_Clause_Views = "BSD-2-Clause-Views" -licenseId BSD_2_Clause = "BSD-2-Clause" -licenseId BSD_3_Clause_Attribution = "BSD-3-Clause-Attribution" -licenseId BSD_3_Clause_Clear = "BSD-3-Clause-Clear" -licenseId BSD_3_Clause_LBNL = "BSD-3-Clause-LBNL" -licenseId BSD_3_Clause_No_Nuclear_License_2014 = "BSD-3-Clause-No-Nuclear-License-2014" -licenseId BSD_3_Clause_No_Nuclear_License = "BSD-3-Clause-No-Nuclear-License" -licenseId BSD_3_Clause_No_Nuclear_Warranty = "BSD-3-Clause-No-Nuclear-Warranty" -licenseId BSD_3_Clause_Open_MPI = "BSD-3-Clause-Open-MPI" -licenseId BSD_3_Clause = "BSD-3-Clause" -licenseId BSD_4_Clause_UC = "BSD-4-Clause-UC" -licenseId BSD_4_Clause = "BSD-4-Clause" -licenseId BSD_Protection = "BSD-Protection" -licenseId BSD_Source_Code = "BSD-Source-Code" -licenseId BSL_1_0 = "BSL-1.0" -licenseId Bzip2_1_0_5 = "bzip2-1.0.5" -licenseId Bzip2_1_0_6 = "bzip2-1.0.6" -licenseId CAL_1_0_Combined_Work_Exception = "CAL-1.0-Combined-Work-Exception" -licenseId CAL_1_0 = "CAL-1.0" -licenseId Caldera = "Caldera" -licenseId CATOSL_1_1 = "CATOSL-1.1" -licenseId CC_BY_1_0 = "CC-BY-1.0" -licenseId CC_BY_2_0 = "CC-BY-2.0" -licenseId CC_BY_2_5 = "CC-BY-2.5" -licenseId CC_BY_3_0_AT = "CC-BY-3.0-AT" -licenseId CC_BY_3_0 = "CC-BY-3.0" -licenseId CC_BY_4_0 = "CC-BY-4.0" -licenseId CC_BY_NC_1_0 = "CC-BY-NC-1.0" -licenseId CC_BY_NC_2_0 = "CC-BY-NC-2.0" -licenseId CC_BY_NC_2_5 = "CC-BY-NC-2.5" -licenseId CC_BY_NC_3_0 = "CC-BY-NC-3.0" -licenseId CC_BY_NC_4_0 = "CC-BY-NC-4.0" -licenseId CC_BY_NC_ND_1_0 = "CC-BY-NC-ND-1.0" -licenseId CC_BY_NC_ND_2_0 = "CC-BY-NC-ND-2.0" -licenseId CC_BY_NC_ND_2_5 = "CC-BY-NC-ND-2.5" -licenseId CC_BY_NC_ND_3_0_IGO = "CC-BY-NC-ND-3.0-IGO" -licenseId CC_BY_NC_ND_3_0 = "CC-BY-NC-ND-3.0" -licenseId CC_BY_NC_ND_4_0 = "CC-BY-NC-ND-4.0" -licenseId CC_BY_NC_SA_1_0 = "CC-BY-NC-SA-1.0" -licenseId CC_BY_NC_SA_2_0 = "CC-BY-NC-SA-2.0" -licenseId CC_BY_NC_SA_2_5 = "CC-BY-NC-SA-2.5" -licenseId CC_BY_NC_SA_3_0 = "CC-BY-NC-SA-3.0" -licenseId CC_BY_NC_SA_4_0 = "CC-BY-NC-SA-4.0" -licenseId CC_BY_ND_1_0 = "CC-BY-ND-1.0" -licenseId CC_BY_ND_2_0 = "CC-BY-ND-2.0" -licenseId CC_BY_ND_2_5 = "CC-BY-ND-2.5" -licenseId CC_BY_ND_3_0 = "CC-BY-ND-3.0" -licenseId CC_BY_ND_4_0 = "CC-BY-ND-4.0" -licenseId CC_BY_SA_1_0 = "CC-BY-SA-1.0" -licenseId CC_BY_SA_2_0 = "CC-BY-SA-2.0" -licenseId CC_BY_SA_2_5 = "CC-BY-SA-2.5" -licenseId CC_BY_SA_3_0_AT = "CC-BY-SA-3.0-AT" -licenseId CC_BY_SA_3_0 = "CC-BY-SA-3.0" -licenseId CC_BY_SA_4_0 = "CC-BY-SA-4.0" -licenseId CC_PDDC = "CC-PDDC" -licenseId CC0_1_0 = "CC0-1.0" -licenseId CDDL_1_0 = "CDDL-1.0" -licenseId CDDL_1_1 = "CDDL-1.1" -licenseId CDLA_Permissive_1_0 = "CDLA-Permissive-1.0" -licenseId CDLA_Sharing_1_0 = "CDLA-Sharing-1.0" -licenseId CECILL_1_0 = "CECILL-1.0" -licenseId CECILL_1_1 = "CECILL-1.1" -licenseId CECILL_2_0 = "CECILL-2.0" -licenseId CECILL_2_1 = "CECILL-2.1" -licenseId CECILL_B = "CECILL-B" -licenseId CECILL_C = "CECILL-C" -licenseId CERN_OHL_1_1 = "CERN-OHL-1.1" -licenseId CERN_OHL_1_2 = "CERN-OHL-1.2" -licenseId CERN_OHL_P_2_0 = "CERN-OHL-P-2.0" -licenseId CERN_OHL_S_2_0 = "CERN-OHL-S-2.0" -licenseId CERN_OHL_W_2_0 = "CERN-OHL-W-2.0" -licenseId ClArtistic = "ClArtistic" -licenseId CNRI_Jython = "CNRI-Jython" -licenseId CNRI_Python_GPL_Compatible = "CNRI-Python-GPL-Compatible" -licenseId CNRI_Python = "CNRI-Python" -licenseId Condor_1_1 = "Condor-1.1" -licenseId Copyleft_next_0_3_0 = "copyleft-next-0.3.0" -licenseId Copyleft_next_0_3_1 = "copyleft-next-0.3.1" -licenseId CPAL_1_0 = "CPAL-1.0" -licenseId CPL_1_0 = "CPL-1.0" -licenseId CPOL_1_02 = "CPOL-1.02" -licenseId Crossword = "Crossword" -licenseId CrystalStacker = "CrystalStacker" -licenseId CUA_OPL_1_0 = "CUA-OPL-1.0" -licenseId Cube = "Cube" -licenseId Curl = "curl" -licenseId D_FSL_1_0 = "D-FSL-1.0" -licenseId Diffmark = "diffmark" -licenseId DOC = "DOC" -licenseId Dotseqn = "Dotseqn" -licenseId DSDP = "DSDP" -licenseId Dvipdfm = "dvipdfm" -licenseId ECL_1_0 = "ECL-1.0" -licenseId ECL_2_0 = "ECL-2.0" -licenseId EFL_1_0 = "EFL-1.0" -licenseId EFL_2_0 = "EFL-2.0" -licenseId EGenix = "eGenix" -licenseId Entessa = "Entessa" -licenseId EPICS = "EPICS" -licenseId EPL_1_0 = "EPL-1.0" -licenseId EPL_2_0 = "EPL-2.0" -licenseId ErlPL_1_1 = "ErlPL-1.1" -licenseId Etalab_2_0 = "etalab-2.0" -licenseId EUDatagrid = "EUDatagrid" -licenseId EUPL_1_0 = "EUPL-1.0" -licenseId EUPL_1_1 = "EUPL-1.1" -licenseId EUPL_1_2 = "EUPL-1.2" -licenseId Eurosym = "Eurosym" -licenseId Fair = "Fair" -licenseId Frameworx_1_0 = "Frameworx-1.0" -licenseId FreeImage = "FreeImage" -licenseId FSFAP = "FSFAP" -licenseId FSFULLR = "FSFULLR" -licenseId FSFUL = "FSFUL" -licenseId FTL = "FTL" -licenseId GFDL_1_1_invariants_only = "GFDL-1.1-invariants-only" -licenseId GFDL_1_1_invariants_or_later = "GFDL-1.1-invariants-or-later" -licenseId GFDL_1_1_no_invariants_only = "GFDL-1.1-no-invariants-only" -licenseId GFDL_1_1_no_invariants_or_later = "GFDL-1.1-no-invariants-or-later" -licenseId GFDL_1_1_only = "GFDL-1.1-only" -licenseId GFDL_1_1_or_later = "GFDL-1.1-or-later" -licenseId GFDL_1_2_invariants_only = "GFDL-1.2-invariants-only" -licenseId GFDL_1_2_invariants_or_later = "GFDL-1.2-invariants-or-later" -licenseId GFDL_1_2_no_invariants_only = "GFDL-1.2-no-invariants-only" -licenseId GFDL_1_2_no_invariants_or_later = "GFDL-1.2-no-invariants-or-later" -licenseId GFDL_1_2_only = "GFDL-1.2-only" -licenseId GFDL_1_2_or_later = "GFDL-1.2-or-later" -licenseId GFDL_1_3_invariants_only = "GFDL-1.3-invariants-only" -licenseId GFDL_1_3_invariants_or_later = "GFDL-1.3-invariants-or-later" -licenseId GFDL_1_3_no_invariants_only = "GFDL-1.3-no-invariants-only" -licenseId GFDL_1_3_no_invariants_or_later = "GFDL-1.3-no-invariants-or-later" -licenseId GFDL_1_3_only = "GFDL-1.3-only" -licenseId GFDL_1_3_or_later = "GFDL-1.3-or-later" -licenseId Giftware = "Giftware" -licenseId GL2PS = "GL2PS" -licenseId Glide = "Glide" -licenseId Glulxe = "Glulxe" -licenseId GLWTPL = "GLWTPL" -licenseId Gnuplot = "gnuplot" -licenseId GPL_1_0_only = "GPL-1.0-only" -licenseId GPL_1_0_or_later = "GPL-1.0-or-later" -licenseId GPL_2_0_only = "GPL-2.0-only" -licenseId GPL_2_0_or_later = "GPL-2.0-or-later" -licenseId GPL_3_0_only = "GPL-3.0-only" -licenseId GPL_3_0_or_later = "GPL-3.0-or-later" -licenseId GSOAP_1_3b = "gSOAP-1.3b" -licenseId HaskellReport = "HaskellReport" -licenseId Hippocratic_2_1 = "Hippocratic-2.1" -licenseId HPND_sell_variant = "HPND-sell-variant" -licenseId HPND = "HPND" -licenseId IBM_pibs = "IBM-pibs" -licenseId ICU = "ICU" -licenseId IJG = "IJG" -licenseId ImageMagick = "ImageMagick" -licenseId IMatix = "iMatix" -licenseId Imlib2 = "Imlib2" -licenseId Info_ZIP = "Info-ZIP" -licenseId Intel_ACPI = "Intel-ACPI" -licenseId Intel = "Intel" -licenseId Interbase_1_0 = "Interbase-1.0" -licenseId IPA = "IPA" -licenseId IPL_1_0 = "IPL-1.0" -licenseId ISC = "ISC" -licenseId JasPer_2_0 = "JasPer-2.0" -licenseId JPNIC = "JPNIC" -licenseId JSON = "JSON" -licenseId LAL_1_2 = "LAL-1.2" -licenseId LAL_1_3 = "LAL-1.3" -licenseId Latex2e = "Latex2e" -licenseId Leptonica = "Leptonica" -licenseId LGPL_2_0_only = "LGPL-2.0-only" -licenseId LGPL_2_0_or_later = "LGPL-2.0-or-later" -licenseId LGPL_2_1_only = "LGPL-2.1-only" -licenseId LGPL_2_1_or_later = "LGPL-2.1-or-later" -licenseId LGPL_3_0_only = "LGPL-3.0-only" -licenseId LGPL_3_0_or_later = "LGPL-3.0-or-later" -licenseId LGPLLR = "LGPLLR" -licenseId Libpng_2_0 = "libpng-2.0" -licenseId Libpng = "Libpng" -licenseId Libselinux_1_0 = "libselinux-1.0" -licenseId Libtiff = "libtiff" -licenseId LiLiQ_P_1_1 = "LiLiQ-P-1.1" -licenseId LiLiQ_R_1_1 = "LiLiQ-R-1.1" -licenseId LiLiQ_Rplus_1_1 = "LiLiQ-Rplus-1.1" -licenseId Linux_OpenIB = "Linux-OpenIB" -licenseId LPL_1_02 = "LPL-1.02" -licenseId LPL_1_0 = "LPL-1.0" -licenseId LPPL_1_0 = "LPPL-1.0" -licenseId LPPL_1_1 = "LPPL-1.1" -licenseId LPPL_1_2 = "LPPL-1.2" -licenseId LPPL_1_3a = "LPPL-1.3a" -licenseId LPPL_1_3c = "LPPL-1.3c" -licenseId MakeIndex = "MakeIndex" -licenseId MirOS = "MirOS" -licenseId MIT_0 = "MIT-0" -licenseId MIT_advertising = "MIT-advertising" -licenseId MIT_CMU = "MIT-CMU" -licenseId MIT_enna = "MIT-enna" -licenseId MIT_feh = "MIT-feh" -licenseId MITNFA = "MITNFA" -licenseId MIT = "MIT" -licenseId Motosoto = "Motosoto" -licenseId Mpich2 = "mpich2" -licenseId MPL_1_0 = "MPL-1.0" -licenseId MPL_1_1 = "MPL-1.1" -licenseId MPL_2_0_no_copyleft_exception = "MPL-2.0-no-copyleft-exception" -licenseId MPL_2_0 = "MPL-2.0" -licenseId MS_PL = "MS-PL" -licenseId MS_RL = "MS-RL" -licenseId MTLL = "MTLL" -licenseId MulanPSL_1_0 = "MulanPSL-1.0" -licenseId MulanPSL_2_0 = "MulanPSL-2.0" -licenseId Multics = "Multics" -licenseId Mup = "Mup" -licenseId NASA_1_3 = "NASA-1.3" -licenseId Naumen = "Naumen" -licenseId NBPL_1_0 = "NBPL-1.0" -licenseId NCGL_UK_2_0 = "NCGL-UK-2.0" -licenseId NCSA = "NCSA" -licenseId Net_SNMP = "Net-SNMP" -licenseId NetCDF = "NetCDF" -licenseId Newsletr = "Newsletr" -licenseId NGPL = "NGPL" -licenseId NIST_PD_fallback = "NIST-PD-fallback" -licenseId NIST_PD = "NIST-PD" -licenseId NLOD_1_0 = "NLOD-1.0" -licenseId NLPL = "NLPL" -licenseId Nokia = "Nokia" -licenseId NOSL = "NOSL" -licenseId Noweb = "Noweb" -licenseId NPL_1_0 = "NPL-1.0" -licenseId NPL_1_1 = "NPL-1.1" -licenseId NPOSL_3_0 = "NPOSL-3.0" -licenseId NRL = "NRL" -licenseId NTP_0 = "NTP-0" -licenseId NTP = "NTP" -licenseId O_UDA_1_0 = "O-UDA-1.0" -licenseId OCCT_PL = "OCCT-PL" -licenseId OCLC_2_0 = "OCLC-2.0" -licenseId ODbL_1_0 = "ODbL-1.0" -licenseId ODC_By_1_0 = "ODC-By-1.0" -licenseId OFL_1_0_no_RFN = "OFL-1.0-no-RFN" -licenseId OFL_1_0_RFN = "OFL-1.0-RFN" -licenseId OFL_1_0 = "OFL-1.0" -licenseId OFL_1_1_no_RFN = "OFL-1.1-no-RFN" -licenseId OFL_1_1_RFN = "OFL-1.1-RFN" -licenseId OFL_1_1 = "OFL-1.1" -licenseId OGC_1_0 = "OGC-1.0" -licenseId OGL_Canada_2_0 = "OGL-Canada-2.0" -licenseId OGL_UK_1_0 = "OGL-UK-1.0" -licenseId OGL_UK_2_0 = "OGL-UK-2.0" -licenseId OGL_UK_3_0 = "OGL-UK-3.0" -licenseId OGTSL = "OGTSL" -licenseId OLDAP_1_1 = "OLDAP-1.1" -licenseId OLDAP_1_2 = "OLDAP-1.2" -licenseId OLDAP_1_3 = "OLDAP-1.3" -licenseId OLDAP_1_4 = "OLDAP-1.4" -licenseId OLDAP_2_0_1 = "OLDAP-2.0.1" -licenseId OLDAP_2_0 = "OLDAP-2.0" -licenseId OLDAP_2_1 = "OLDAP-2.1" -licenseId OLDAP_2_2_1 = "OLDAP-2.2.1" -licenseId OLDAP_2_2_2 = "OLDAP-2.2.2" -licenseId OLDAP_2_2 = "OLDAP-2.2" -licenseId OLDAP_2_3 = "OLDAP-2.3" -licenseId OLDAP_2_4 = "OLDAP-2.4" -licenseId OLDAP_2_5 = "OLDAP-2.5" -licenseId OLDAP_2_6 = "OLDAP-2.6" -licenseId OLDAP_2_7 = "OLDAP-2.7" -licenseId OLDAP_2_8 = "OLDAP-2.8" -licenseId OML = "OML" -licenseId OpenSSL = "OpenSSL" -licenseId OPL_1_0 = "OPL-1.0" -licenseId OSET_PL_2_1 = "OSET-PL-2.1" -licenseId OSL_1_0 = "OSL-1.0" -licenseId OSL_1_1 = "OSL-1.1" -licenseId OSL_2_0 = "OSL-2.0" -licenseId OSL_2_1 = "OSL-2.1" -licenseId OSL_3_0 = "OSL-3.0" -licenseId Parity_6_0_0 = "Parity-6.0.0" -licenseId Parity_7_0_0 = "Parity-7.0.0" -licenseId PDDL_1_0 = "PDDL-1.0" -licenseId PHP_3_01 = "PHP-3.01" -licenseId PHP_3_0 = "PHP-3.0" -licenseId Plexus = "Plexus" -licenseId PolyForm_Noncommercial_1_0_0 = "PolyForm-Noncommercial-1.0.0" -licenseId PolyForm_Small_Business_1_0_0 = "PolyForm-Small-Business-1.0.0" -licenseId PostgreSQL = "PostgreSQL" -licenseId PSF_2_0 = "PSF-2.0" -licenseId Psfrag = "psfrag" -licenseId Psutils = "psutils" -licenseId Python_2_0 = "Python-2.0" -licenseId Qhull = "Qhull" -licenseId QPL_1_0 = "QPL-1.0" -licenseId Rdisc = "Rdisc" -licenseId RHeCos_1_1 = "RHeCos-1.1" -licenseId RPL_1_1 = "RPL-1.1" -licenseId RPL_1_5 = "RPL-1.5" -licenseId RPSL_1_0 = "RPSL-1.0" -licenseId RSA_MD = "RSA-MD" -licenseId RSCPL = "RSCPL" -licenseId Ruby = "Ruby" -licenseId SAX_PD = "SAX-PD" -licenseId Saxpath = "Saxpath" -licenseId SCEA = "SCEA" -licenseId Sendmail_8_23 = "Sendmail-8.23" -licenseId Sendmail = "Sendmail" -licenseId SGI_B_1_0 = "SGI-B-1.0" -licenseId SGI_B_1_1 = "SGI-B-1.1" -licenseId SGI_B_2_0 = "SGI-B-2.0" -licenseId SHL_0_51 = "SHL-0.51" -licenseId SHL_0_5 = "SHL-0.5" -licenseId SimPL_2_0 = "SimPL-2.0" -licenseId SISSL_1_2 = "SISSL-1.2" -licenseId SISSL = "SISSL" -licenseId Sleepycat = "Sleepycat" -licenseId SMLNJ = "SMLNJ" -licenseId SMPPL = "SMPPL" -licenseId SNIA = "SNIA" -licenseId Spencer_86 = "Spencer-86" -licenseId Spencer_94 = "Spencer-94" -licenseId Spencer_99 = "Spencer-99" -licenseId SPL_1_0 = "SPL-1.0" -licenseId SSH_OpenSSH = "SSH-OpenSSH" -licenseId SSH_short = "SSH-short" -licenseId SSPL_1_0 = "SSPL-1.0" -licenseId SugarCRM_1_1_3 = "SugarCRM-1.1.3" -licenseId SWL = "SWL" -licenseId TAPR_OHL_1_0 = "TAPR-OHL-1.0" -licenseId TCL = "TCL" -licenseId TCP_wrappers = "TCP-wrappers" -licenseId TMate = "TMate" -licenseId TORQUE_1_1 = "TORQUE-1.1" -licenseId TOSL = "TOSL" -licenseId TU_Berlin_1_0 = "TU-Berlin-1.0" -licenseId TU_Berlin_2_0 = "TU-Berlin-2.0" -licenseId UCL_1_0 = "UCL-1.0" -licenseId Unicode_DFS_2015 = "Unicode-DFS-2015" -licenseId Unicode_DFS_2016 = "Unicode-DFS-2016" -licenseId Unicode_TOU = "Unicode-TOU" -licenseId Unlicense = "Unlicense" -licenseId UPL_1_0 = "UPL-1.0" -licenseId Vim = "Vim" -licenseId VOSTROM = "VOSTROM" -licenseId VSL_1_0 = "VSL-1.0" -licenseId W3C_19980720 = "W3C-19980720" -licenseId W3C_20150513 = "W3C-20150513" -licenseId W3C = "W3C" -licenseId Watcom_1_0 = "Watcom-1.0" -licenseId Wsuipa = "Wsuipa" -licenseId WTFPL = "WTFPL" -licenseId X11 = "X11" -licenseId Xerox = "Xerox" -licenseId XFree86_1_1 = "XFree86-1.1" -licenseId Xinetd = "xinetd" -licenseId Xnet = "Xnet" -licenseId Xpp = "xpp" -licenseId XSkat = "XSkat" -licenseId YPL_1_0 = "YPL-1.0" -licenseId YPL_1_1 = "YPL-1.1" -licenseId Zed = "Zed" -licenseId Zend_2_0 = "Zend-2.0" -licenseId Zimbra_1_3 = "Zimbra-1.3" -licenseId Zimbra_1_4 = "Zimbra-1.4" -licenseId Zlib_acknowledgement = "zlib-acknowledgement" -licenseId Zlib = "Zlib" -licenseId ZPL_1_1 = "ZPL-1.1" -licenseId ZPL_2_0 = "ZPL-2.0" -licenseId ZPL_2_1 = "ZPL-2.1" - --- | License name, e.g. @"GNU General Public License v2.0 only"@ -licenseName :: LicenseId -> String -licenseName NullBSD = "BSD Zero Clause License" -licenseName AAL = "Attribution Assurance License" -licenseName Abstyles = "Abstyles License" -licenseName Adobe_2006 = "Adobe Systems Incorporated Source Code License Agreement" -licenseName Adobe_Glyph = "Adobe Glyph List License" -licenseName ADSL = "Amazon Digital Services License" -licenseName AFL_1_1 = "Academic Free License v1.1" -licenseName AFL_1_2 = "Academic Free License v1.2" -licenseName AFL_2_0 = "Academic Free License v2.0" -licenseName AFL_2_1 = "Academic Free License v2.1" -licenseName AFL_3_0 = "Academic Free License v3.0" -licenseName Afmparse = "Afmparse License" -licenseName AGPL_1_0 = "Affero General Public License v1.0" -licenseName AGPL_1_0_only = "Affero General Public License v1.0 only" -licenseName AGPL_1_0_or_later = "Affero General Public License v1.0 or later" -licenseName AGPL_3_0_only = "GNU Affero General Public License v3.0 only" -licenseName AGPL_3_0_or_later = "GNU Affero General Public License v3.0 or later" -licenseName Aladdin = "Aladdin Free Public License" -licenseName AMDPLPA = "AMD's plpa_map.c License" -licenseName AML = "Apple MIT License" -licenseName AMPAS = "Academy of Motion Picture Arts and Sciences BSD" -licenseName ANTLR_PD = "ANTLR Software Rights Notice" -licenseName Apache_1_0 = "Apache License 1.0" -licenseName Apache_1_1 = "Apache License 1.1" -licenseName Apache_2_0 = "Apache License 2.0" -licenseName APAFML = "Adobe Postscript AFM License" -licenseName APL_1_0 = "Adaptive Public License 1.0" -licenseName APSL_1_0 = "Apple Public Source License 1.0" -licenseName APSL_1_1 = "Apple Public Source License 1.1" -licenseName APSL_1_2 = "Apple Public Source License 1.2" -licenseName APSL_2_0 = "Apple Public Source License 2.0" -licenseName Artistic_1_0_cl8 = "Artistic License 1.0 w/clause 8" -licenseName Artistic_1_0_Perl = "Artistic License 1.0 (Perl)" -licenseName Artistic_1_0 = "Artistic License 1.0" -licenseName Artistic_2_0 = "Artistic License 2.0" -licenseName Bahyph = "Bahyph License" -licenseName Barr = "Barr License" -licenseName Beerware = "Beerware License" -licenseName BitTorrent_1_0 = "BitTorrent Open Source License v1.0" -licenseName BitTorrent_1_1 = "BitTorrent Open Source License v1.1" -licenseName Blessing = "SQLite Blessing" -licenseName BlueOak_1_0_0 = "Blue Oak Model License 1.0.0" -licenseName Borceux = "Borceux license" -licenseName BSD_1_Clause = "BSD 1-Clause License" -licenseName BSD_2_Clause_FreeBSD = "BSD 2-Clause FreeBSD License" -licenseName BSD_2_Clause_NetBSD = "BSD 2-Clause NetBSD License" -licenseName BSD_2_Clause_Patent = "BSD-2-Clause Plus Patent License" -licenseName BSD_2_Clause_Views = "BSD 2-Clause with views sentence" -licenseName BSD_2_Clause = "BSD 2-Clause \"Simplified\" License" -licenseName BSD_3_Clause_Attribution = "BSD with attribution" -licenseName BSD_3_Clause_Clear = "BSD 3-Clause Clear License" -licenseName BSD_3_Clause_LBNL = "Lawrence Berkeley National Labs BSD variant license" -licenseName BSD_3_Clause_No_Nuclear_License_2014 = "BSD 3-Clause No Nuclear License 2014" -licenseName BSD_3_Clause_No_Nuclear_License = "BSD 3-Clause No Nuclear License" -licenseName BSD_3_Clause_No_Nuclear_Warranty = "BSD 3-Clause No Nuclear Warranty" -licenseName BSD_3_Clause_Open_MPI = "BSD 3-Clause Open MPI variant" -licenseName BSD_3_Clause = "BSD 3-Clause \"New\" or \"Revised\" License" -licenseName BSD_4_Clause_UC = "BSD-4-Clause (University of California-Specific)" -licenseName BSD_4_Clause = "BSD 4-Clause \"Original\" or \"Old\" License" -licenseName BSD_Protection = "BSD Protection License" -licenseName BSD_Source_Code = "BSD Source Code Attribution" -licenseName BSL_1_0 = "Boost Software License 1.0" -licenseName Bzip2_1_0_5 = "bzip2 and libbzip2 License v1.0.5" -licenseName Bzip2_1_0_6 = "bzip2 and libbzip2 License v1.0.6" -licenseName CAL_1_0_Combined_Work_Exception = "Cryptographic Autonomy License 1.0 (Combined Work Exception)" -licenseName CAL_1_0 = "Cryptographic Autonomy License 1.0" -licenseName Caldera = "Caldera License" -licenseName CATOSL_1_1 = "Computer Associates Trusted Open Source License 1.1" -licenseName CC_BY_1_0 = "Creative Commons Attribution 1.0 Generic" -licenseName CC_BY_2_0 = "Creative Commons Attribution 2.0 Generic" -licenseName CC_BY_2_5 = "Creative Commons Attribution 2.5 Generic" -licenseName CC_BY_3_0_AT = "Creative Commons Attribution 3.0 Austria" -licenseName CC_BY_3_0 = "Creative Commons Attribution 3.0 Unported" -licenseName CC_BY_4_0 = "Creative Commons Attribution 4.0 International" -licenseName CC_BY_NC_1_0 = "Creative Commons Attribution Non Commercial 1.0 Generic" -licenseName CC_BY_NC_2_0 = "Creative Commons Attribution Non Commercial 2.0 Generic" -licenseName CC_BY_NC_2_5 = "Creative Commons Attribution Non Commercial 2.5 Generic" -licenseName CC_BY_NC_3_0 = "Creative Commons Attribution Non Commercial 3.0 Unported" -licenseName CC_BY_NC_4_0 = "Creative Commons Attribution Non Commercial 4.0 International" -licenseName CC_BY_NC_ND_1_0 = "Creative Commons Attribution Non Commercial No Derivatives 1.0 Generic" -licenseName CC_BY_NC_ND_2_0 = "Creative Commons Attribution Non Commercial No Derivatives 2.0 Generic" -licenseName CC_BY_NC_ND_2_5 = "Creative Commons Attribution Non Commercial No Derivatives 2.5 Generic" -licenseName CC_BY_NC_ND_3_0_IGO = "Creative Commons Attribution Non Commercial No Derivatives 3.0 IGO" -licenseName CC_BY_NC_ND_3_0 = "Creative Commons Attribution Non Commercial No Derivatives 3.0 Unported" -licenseName CC_BY_NC_ND_4_0 = "Creative Commons Attribution Non Commercial No Derivatives 4.0 International" -licenseName CC_BY_NC_SA_1_0 = "Creative Commons Attribution Non Commercial Share Alike 1.0 Generic" -licenseName CC_BY_NC_SA_2_0 = "Creative Commons Attribution Non Commercial Share Alike 2.0 Generic" -licenseName CC_BY_NC_SA_2_5 = "Creative Commons Attribution Non Commercial Share Alike 2.5 Generic" -licenseName CC_BY_NC_SA_3_0 = "Creative Commons Attribution Non Commercial Share Alike 3.0 Unported" -licenseName CC_BY_NC_SA_4_0 = "Creative Commons Attribution Non Commercial Share Alike 4.0 International" -licenseName CC_BY_ND_1_0 = "Creative Commons Attribution No Derivatives 1.0 Generic" -licenseName CC_BY_ND_2_0 = "Creative Commons Attribution No Derivatives 2.0 Generic" -licenseName CC_BY_ND_2_5 = "Creative Commons Attribution No Derivatives 2.5 Generic" -licenseName CC_BY_ND_3_0 = "Creative Commons Attribution No Derivatives 3.0 Unported" -licenseName CC_BY_ND_4_0 = "Creative Commons Attribution No Derivatives 4.0 International" -licenseName CC_BY_SA_1_0 = "Creative Commons Attribution Share Alike 1.0 Generic" -licenseName CC_BY_SA_2_0 = "Creative Commons Attribution Share Alike 2.0 Generic" -licenseName CC_BY_SA_2_5 = "Creative Commons Attribution Share Alike 2.5 Generic" -licenseName CC_BY_SA_3_0_AT = "Creative Commons Attribution-Share Alike 3.0 Austria" -licenseName CC_BY_SA_3_0 = "Creative Commons Attribution Share Alike 3.0 Unported" -licenseName CC_BY_SA_4_0 = "Creative Commons Attribution Share Alike 4.0 International" -licenseName CC_PDDC = "Creative Commons Public Domain Dedication and Certification" -licenseName CC0_1_0 = "Creative Commons Zero v1.0 Universal" -licenseName CDDL_1_0 = "Common Development and Distribution License 1.0" -licenseName CDDL_1_1 = "Common Development and Distribution License 1.1" -licenseName CDLA_Permissive_1_0 = "Community Data License Agreement Permissive 1.0" -licenseName CDLA_Sharing_1_0 = "Community Data License Agreement Sharing 1.0" -licenseName CECILL_1_0 = "CeCILL Free Software License Agreement v1.0" -licenseName CECILL_1_1 = "CeCILL Free Software License Agreement v1.1" -licenseName CECILL_2_0 = "CeCILL Free Software License Agreement v2.0" -licenseName CECILL_2_1 = "CeCILL Free Software License Agreement v2.1" -licenseName CECILL_B = "CeCILL-B Free Software License Agreement" -licenseName CECILL_C = "CeCILL-C Free Software License Agreement" -licenseName CERN_OHL_1_1 = "CERN Open Hardware Licence v1.1" -licenseName CERN_OHL_1_2 = "CERN Open Hardware Licence v1.2" -licenseName CERN_OHL_P_2_0 = "CERN Open Hardware Licence Version 2 - Permissive" -licenseName CERN_OHL_S_2_0 = "CERN Open Hardware Licence Version 2 - Strongly Reciprocal" -licenseName CERN_OHL_W_2_0 = "CERN Open Hardware Licence Version 2 - Weakly Reciprocal" -licenseName ClArtistic = "Clarified Artistic License" -licenseName CNRI_Jython = "CNRI Jython License" -licenseName CNRI_Python_GPL_Compatible = "CNRI Python Open Source GPL Compatible License Agreement" -licenseName CNRI_Python = "CNRI Python License" -licenseName Condor_1_1 = "Condor Public License v1.1" -licenseName Copyleft_next_0_3_0 = "copyleft-next 0.3.0" -licenseName Copyleft_next_0_3_1 = "copyleft-next 0.3.1" -licenseName CPAL_1_0 = "Common Public Attribution License 1.0" -licenseName CPL_1_0 = "Common Public License 1.0" -licenseName CPOL_1_02 = "Code Project Open License 1.02" -licenseName Crossword = "Crossword License" -licenseName CrystalStacker = "CrystalStacker License" -licenseName CUA_OPL_1_0 = "CUA Office Public License v1.0" -licenseName Cube = "Cube License" -licenseName Curl = "curl License" -licenseName D_FSL_1_0 = "Deutsche Freie Software Lizenz" -licenseName Diffmark = "diffmark license" -licenseName DOC = "DOC License" -licenseName Dotseqn = "Dotseqn License" -licenseName DSDP = "DSDP License" -licenseName Dvipdfm = "dvipdfm License" -licenseName ECL_1_0 = "Educational Community License v1.0" -licenseName ECL_2_0 = "Educational Community License v2.0" -licenseName EFL_1_0 = "Eiffel Forum License v1.0" -licenseName EFL_2_0 = "Eiffel Forum License v2.0" -licenseName EGenix = "eGenix.com Public License 1.1.0" -licenseName Entessa = "Entessa Public License v1.0" -licenseName EPICS = "EPICS Open License" -licenseName EPL_1_0 = "Eclipse Public License 1.0" -licenseName EPL_2_0 = "Eclipse Public License 2.0" -licenseName ErlPL_1_1 = "Erlang Public License v1.1" -licenseName Etalab_2_0 = "Etalab Open License 2.0" -licenseName EUDatagrid = "EU DataGrid Software License" -licenseName EUPL_1_0 = "European Union Public License 1.0" -licenseName EUPL_1_1 = "European Union Public License 1.1" -licenseName EUPL_1_2 = "European Union Public License 1.2" -licenseName Eurosym = "Eurosym License" -licenseName Fair = "Fair License" -licenseName Frameworx_1_0 = "Frameworx Open License 1.0" -licenseName FreeImage = "FreeImage Public License v1.0" -licenseName FSFAP = "FSF All Permissive License" -licenseName FSFULLR = "FSF Unlimited License (with License Retention)" -licenseName FSFUL = "FSF Unlimited License" -licenseName FTL = "Freetype Project License" -licenseName GFDL_1_1_invariants_only = "GNU Free Documentation License v1.1 only - invariants" -licenseName GFDL_1_1_invariants_or_later = "GNU Free Documentation License v1.1 or later - invariants" -licenseName GFDL_1_1_no_invariants_only = "GNU Free Documentation License v1.1 only - no invariants" -licenseName GFDL_1_1_no_invariants_or_later = "GNU Free Documentation License v1.1 or later - no invariants" -licenseName GFDL_1_1_only = "GNU Free Documentation License v1.1 only" -licenseName GFDL_1_1_or_later = "GNU Free Documentation License v1.1 or later" -licenseName GFDL_1_2_invariants_only = "GNU Free Documentation License v1.2 only - invariants" -licenseName GFDL_1_2_invariants_or_later = "GNU Free Documentation License v1.2 or later - invariants" -licenseName GFDL_1_2_no_invariants_only = "GNU Free Documentation License v1.2 only - no invariants" -licenseName GFDL_1_2_no_invariants_or_later = "GNU Free Documentation License v1.2 or later - no invariants" -licenseName GFDL_1_2_only = "GNU Free Documentation License v1.2 only" -licenseName GFDL_1_2_or_later = "GNU Free Documentation License v1.2 or later" -licenseName GFDL_1_3_invariants_only = "GNU Free Documentation License v1.3 only - invariants" -licenseName GFDL_1_3_invariants_or_later = "GNU Free Documentation License v1.3 or later - invariants" -licenseName GFDL_1_3_no_invariants_only = "GNU Free Documentation License v1.3 only - no invariants" -licenseName GFDL_1_3_no_invariants_or_later = "GNU Free Documentation License v1.3 or later - no invariants" -licenseName GFDL_1_3_only = "GNU Free Documentation License v1.3 only" -licenseName GFDL_1_3_or_later = "GNU Free Documentation License v1.3 or later" -licenseName Giftware = "Giftware License" -licenseName GL2PS = "GL2PS License" -licenseName Glide = "3dfx Glide License" -licenseName Glulxe = "Glulxe License" -licenseName GLWTPL = "Good Luck With That Public License" -licenseName Gnuplot = "gnuplot License" -licenseName GPL_1_0_only = "GNU General Public License v1.0 only" -licenseName GPL_1_0_or_later = "GNU General Public License v1.0 or later" -licenseName GPL_2_0_only = "GNU General Public License v2.0 only" -licenseName GPL_2_0_or_later = "GNU General Public License v2.0 or later" -licenseName GPL_3_0_only = "GNU General Public License v3.0 only" -licenseName GPL_3_0_or_later = "GNU General Public License v3.0 or later" -licenseName GSOAP_1_3b = "gSOAP Public License v1.3b" -licenseName HaskellReport = "Haskell Language Report License" -licenseName Hippocratic_2_1 = "Hippocratic License 2.1" -licenseName HPND_sell_variant = "Historical Permission Notice and Disclaimer - sell variant" -licenseName HPND = "Historical Permission Notice and Disclaimer" -licenseName IBM_pibs = "IBM PowerPC Initialization and Boot Software" -licenseName ICU = "ICU License" -licenseName IJG = "Independent JPEG Group License" -licenseName ImageMagick = "ImageMagick License" -licenseName IMatix = "iMatix Standard Function Library Agreement" -licenseName Imlib2 = "Imlib2 License" -licenseName Info_ZIP = "Info-ZIP License" -licenseName Intel_ACPI = "Intel ACPI Software License Agreement" -licenseName Intel = "Intel Open Source License" -licenseName Interbase_1_0 = "Interbase Public License v1.0" -licenseName IPA = "IPA Font License" -licenseName IPL_1_0 = "IBM Public License v1.0" -licenseName ISC = "ISC License" -licenseName JasPer_2_0 = "JasPer License" -licenseName JPNIC = "Japan Network Information Center License" -licenseName JSON = "JSON License" -licenseName LAL_1_2 = "Licence Art Libre 1.2" -licenseName LAL_1_3 = "Licence Art Libre 1.3" -licenseName Latex2e = "Latex2e License" -licenseName Leptonica = "Leptonica License" -licenseName LGPL_2_0_only = "GNU Library General Public License v2 only" -licenseName LGPL_2_0_or_later = "GNU Library General Public License v2 or later" -licenseName LGPL_2_1_only = "GNU Lesser General Public License v2.1 only" -licenseName LGPL_2_1_or_later = "GNU Lesser General Public License v2.1 or later" -licenseName LGPL_3_0_only = "GNU Lesser General Public License v3.0 only" -licenseName LGPL_3_0_or_later = "GNU Lesser General Public License v3.0 or later" -licenseName LGPLLR = "Lesser General Public License For Linguistic Resources" -licenseName Libpng_2_0 = "PNG Reference Library version 2" -licenseName Libpng = "libpng License" -licenseName Libselinux_1_0 = "libselinux public domain notice" -licenseName Libtiff = "libtiff License" -licenseName LiLiQ_P_1_1 = "Licence Libre du Qu\233bec \8211 Permissive version 1.1" -licenseName LiLiQ_R_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 version 1.1" -licenseName LiLiQ_Rplus_1_1 = "Licence Libre du Qu\233bec \8211 R\233ciprocit\233 forte version 1.1" -licenseName Linux_OpenIB = "Linux Kernel Variant of OpenIB.org license" -licenseName LPL_1_02 = "Lucent Public License v1.02" -licenseName LPL_1_0 = "Lucent Public License Version 1.0" -licenseName LPPL_1_0 = "LaTeX Project Public License v1.0" -licenseName LPPL_1_1 = "LaTeX Project Public License v1.1" -licenseName LPPL_1_2 = "LaTeX Project Public License v1.2" -licenseName LPPL_1_3a = "LaTeX Project Public License v1.3a" -licenseName LPPL_1_3c = "LaTeX Project Public License v1.3c" -licenseName MakeIndex = "MakeIndex License" -licenseName MirOS = "The MirOS Licence" -licenseName MIT_0 = "MIT No Attribution" -licenseName MIT_advertising = "Enlightenment License (e16)" -licenseName MIT_CMU = "CMU License" -licenseName MIT_enna = "enna License" -licenseName MIT_feh = "feh License" -licenseName MITNFA = "MIT +no-false-attribs license" -licenseName MIT = "MIT License" -licenseName Motosoto = "Motosoto License" -licenseName Mpich2 = "mpich2 License" -licenseName MPL_1_0 = "Mozilla Public License 1.0" -licenseName MPL_1_1 = "Mozilla Public License 1.1" -licenseName MPL_2_0_no_copyleft_exception = "Mozilla Public License 2.0 (no copyleft exception)" -licenseName MPL_2_0 = "Mozilla Public License 2.0" -licenseName MS_PL = "Microsoft Public License" -licenseName MS_RL = "Microsoft Reciprocal License" -licenseName MTLL = "Matrix Template Library License" -licenseName MulanPSL_1_0 = "Mulan Permissive Software License, Version 1" -licenseName MulanPSL_2_0 = "Mulan Permissive Software License, Version 2" -licenseName Multics = "Multics License" -licenseName Mup = "Mup License" -licenseName NASA_1_3 = "NASA Open Source Agreement 1.3" -licenseName Naumen = "Naumen Public License" -licenseName NBPL_1_0 = "Net Boolean Public License v1" -licenseName NCGL_UK_2_0 = "Non-Commercial Government Licence" -licenseName NCSA = "University of Illinois/NCSA Open Source License" -licenseName Net_SNMP = "Net-SNMP License" -licenseName NetCDF = "NetCDF license" -licenseName Newsletr = "Newsletr License" -licenseName NGPL = "Nethack General Public License" -licenseName NIST_PD_fallback = "NIST Public Domain Notice with license fallback" -licenseName NIST_PD = "NIST Public Domain Notice" -licenseName NLOD_1_0 = "Norwegian Licence for Open Government Data" -licenseName NLPL = "No Limit Public License" -licenseName Nokia = "Nokia Open Source License" -licenseName NOSL = "Netizen Open Source License" -licenseName Noweb = "Noweb License" -licenseName NPL_1_0 = "Netscape Public License v1.0" -licenseName NPL_1_1 = "Netscape Public License v1.1" -licenseName NPOSL_3_0 = "Non-Profit Open Software License 3.0" -licenseName NRL = "NRL License" -licenseName NTP_0 = "NTP No Attribution" -licenseName NTP = "NTP License" -licenseName O_UDA_1_0 = "Open Use of Data Agreement v1.0" -licenseName OCCT_PL = "Open CASCADE Technology Public License" -licenseName OCLC_2_0 = "OCLC Research Public License 2.0" -licenseName ODbL_1_0 = "ODC Open Database License v1.0" -licenseName ODC_By_1_0 = "Open Data Commons Attribution License v1.0" -licenseName OFL_1_0_no_RFN = "SIL Open Font License 1.0 with no Reserved Font Name" -licenseName OFL_1_0_RFN = "SIL Open Font License 1.0 with Reserved Font Name" -licenseName OFL_1_0 = "SIL Open Font License 1.0" -licenseName OFL_1_1_no_RFN = "SIL Open Font License 1.1 with no Reserved Font Name" -licenseName OFL_1_1_RFN = "SIL Open Font License 1.1 with Reserved Font Name" -licenseName OFL_1_1 = "SIL Open Font License 1.1" -licenseName OGC_1_0 = "OGC Software License, Version 1.0" -licenseName OGL_Canada_2_0 = "Open Government Licence - Canada" -licenseName OGL_UK_1_0 = "Open Government Licence v1.0" -licenseName OGL_UK_2_0 = "Open Government Licence v2.0" -licenseName OGL_UK_3_0 = "Open Government Licence v3.0" -licenseName OGTSL = "Open Group Test Suite License" -licenseName OLDAP_1_1 = "Open LDAP Public License v1.1" -licenseName OLDAP_1_2 = "Open LDAP Public License v1.2" -licenseName OLDAP_1_3 = "Open LDAP Public License v1.3" -licenseName OLDAP_1_4 = "Open LDAP Public License v1.4" -licenseName OLDAP_2_0_1 = "Open LDAP Public License v2.0.1" -licenseName OLDAP_2_0 = "Open LDAP Public License v2.0 (or possibly 2.0A and 2.0B)" -licenseName OLDAP_2_1 = "Open LDAP Public License v2.1" -licenseName OLDAP_2_2_1 = "Open LDAP Public License v2.2.1" -licenseName OLDAP_2_2_2 = "Open LDAP Public License 2.2.2" -licenseName OLDAP_2_2 = "Open LDAP Public License v2.2" -licenseName OLDAP_2_3 = "Open LDAP Public License v2.3" -licenseName OLDAP_2_4 = "Open LDAP Public License v2.4" -licenseName OLDAP_2_5 = "Open LDAP Public License v2.5" -licenseName OLDAP_2_6 = "Open LDAP Public License v2.6" -licenseName OLDAP_2_7 = "Open LDAP Public License v2.7" -licenseName OLDAP_2_8 = "Open LDAP Public License v2.8" -licenseName OML = "Open Market License" -licenseName OpenSSL = "OpenSSL License" -licenseName OPL_1_0 = "Open Public License v1.0" -licenseName OSET_PL_2_1 = "OSET Public License version 2.1" -licenseName OSL_1_0 = "Open Software License 1.0" -licenseName OSL_1_1 = "Open Software License 1.1" -licenseName OSL_2_0 = "Open Software License 2.0" -licenseName OSL_2_1 = "Open Software License 2.1" -licenseName OSL_3_0 = "Open Software License 3.0" -licenseName Parity_6_0_0 = "The Parity Public License 6.0.0" -licenseName Parity_7_0_0 = "The Parity Public License 7.0.0" -licenseName PDDL_1_0 = "ODC Public Domain Dedication & License 1.0" -licenseName PHP_3_01 = "PHP License v3.01" -licenseName PHP_3_0 = "PHP License v3.0" -licenseName Plexus = "Plexus Classworlds License" -licenseName PolyForm_Noncommercial_1_0_0 = "PolyForm Noncommercial License 1.0.0" -licenseName PolyForm_Small_Business_1_0_0 = "PolyForm Small Business License 1.0.0" -licenseName PostgreSQL = "PostgreSQL License" -licenseName PSF_2_0 = "Python Software Foundation License 2.0" -licenseName Psfrag = "psfrag License" -licenseName Psutils = "psutils License" -licenseName Python_2_0 = "Python License 2.0" -licenseName Qhull = "Qhull License" -licenseName QPL_1_0 = "Q Public License 1.0" -licenseName Rdisc = "Rdisc License" -licenseName RHeCos_1_1 = "Red Hat eCos Public License v1.1" -licenseName RPL_1_1 = "Reciprocal Public License 1.1" -licenseName RPL_1_5 = "Reciprocal Public License 1.5" -licenseName RPSL_1_0 = "RealNetworks Public Source License v1.0" -licenseName RSA_MD = "RSA Message-Digest License" -licenseName RSCPL = "Ricoh Source Code Public License" -licenseName Ruby = "Ruby License" -licenseName SAX_PD = "Sax Public Domain Notice" -licenseName Saxpath = "Saxpath License" -licenseName SCEA = "SCEA Shared Source License" -licenseName Sendmail_8_23 = "Sendmail License 8.23" -licenseName Sendmail = "Sendmail License" -licenseName SGI_B_1_0 = "SGI Free Software License B v1.0" -licenseName SGI_B_1_1 = "SGI Free Software License B v1.1" -licenseName SGI_B_2_0 = "SGI Free Software License B v2.0" -licenseName SHL_0_51 = "Solderpad Hardware License, Version 0.51" -licenseName SHL_0_5 = "Solderpad Hardware License v0.5" -licenseName SimPL_2_0 = "Simple Public License 2.0" -licenseName SISSL_1_2 = "Sun Industry Standards Source License v1.2" -licenseName SISSL = "Sun Industry Standards Source License v1.1" -licenseName Sleepycat = "Sleepycat License" -licenseName SMLNJ = "Standard ML of New Jersey License" -licenseName SMPPL = "Secure Messaging Protocol Public License" -licenseName SNIA = "SNIA Public License 1.1" -licenseName Spencer_86 = "Spencer License 86" -licenseName Spencer_94 = "Spencer License 94" -licenseName Spencer_99 = "Spencer License 99" -licenseName SPL_1_0 = "Sun Public License v1.0" -licenseName SSH_OpenSSH = "SSH OpenSSH license" -licenseName SSH_short = "SSH short notice" -licenseName SSPL_1_0 = "Server Side Public License, v 1" -licenseName SugarCRM_1_1_3 = "SugarCRM Public License v1.1.3" -licenseName SWL = "Scheme Widget Library (SWL) Software License Agreement" -licenseName TAPR_OHL_1_0 = "TAPR Open Hardware License v1.0" -licenseName TCL = "TCL/TK License" -licenseName TCP_wrappers = "TCP Wrappers License" -licenseName TMate = "TMate Open Source License" -licenseName TORQUE_1_1 = "TORQUE v2.5+ Software License v1.1" -licenseName TOSL = "Trusster Open Source License" -licenseName TU_Berlin_1_0 = "Technische Universitaet Berlin License 1.0" -licenseName TU_Berlin_2_0 = "Technische Universitaet Berlin License 2.0" -licenseName UCL_1_0 = "Upstream Compatibility License v1.0" -licenseName Unicode_DFS_2015 = "Unicode License Agreement - Data Files and Software (2015)" -licenseName Unicode_DFS_2016 = "Unicode License Agreement - Data Files and Software (2016)" -licenseName Unicode_TOU = "Unicode Terms of Use" -licenseName Unlicense = "The Unlicense" -licenseName UPL_1_0 = "Universal Permissive License v1.0" -licenseName Vim = "Vim License" -licenseName VOSTROM = "VOSTROM Public License for Open Source" -licenseName VSL_1_0 = "Vovida Software License v1.0" -licenseName W3C_19980720 = "W3C Software Notice and License (1998-07-20)" -licenseName W3C_20150513 = "W3C Software Notice and Document License (2015-05-13)" -licenseName W3C = "W3C Software Notice and License (2002-12-31)" -licenseName Watcom_1_0 = "Sybase Open Watcom Public License 1.0" -licenseName Wsuipa = "Wsuipa License" -licenseName WTFPL = "Do What The F*ck You Want To Public License" -licenseName X11 = "X11 License" -licenseName Xerox = "Xerox License" -licenseName XFree86_1_1 = "XFree86 License 1.1" -licenseName Xinetd = "xinetd License" -licenseName Xnet = "X.Net License" -licenseName Xpp = "XPP License" -licenseName XSkat = "XSkat License" -licenseName YPL_1_0 = "Yahoo! Public License v1.0" -licenseName YPL_1_1 = "Yahoo! Public License v1.1" -licenseName Zed = "Zed License" -licenseName Zend_2_0 = "Zend License v2.0" -licenseName Zimbra_1_3 = "Zimbra Public License v1.3" -licenseName Zimbra_1_4 = "Zimbra Public License v1.4" -licenseName Zlib_acknowledgement = "zlib/libpng License with Acknowledgement" -licenseName Zlib = "zlib License" -licenseName ZPL_1_1 = "Zope Public License 1.1" -licenseName ZPL_2_0 = "Zope Public License 2.0" -licenseName ZPL_2_1 = "Zope Public License 2.1" - --- | Whether the license is approved by Open Source Initiative (OSI). --- --- See . -licenseIsOsiApproved :: LicenseId -> Bool -licenseIsOsiApproved NullBSD = True -licenseIsOsiApproved AAL = True -licenseIsOsiApproved AFL_1_1 = True -licenseIsOsiApproved AFL_1_2 = True -licenseIsOsiApproved AFL_2_0 = True -licenseIsOsiApproved AFL_2_1 = True -licenseIsOsiApproved AFL_3_0 = True -licenseIsOsiApproved AGPL_3_0_only = True -licenseIsOsiApproved AGPL_3_0_or_later = True -licenseIsOsiApproved Apache_1_1 = True -licenseIsOsiApproved Apache_2_0 = True -licenseIsOsiApproved APL_1_0 = True -licenseIsOsiApproved APSL_1_0 = True -licenseIsOsiApproved APSL_1_1 = True -licenseIsOsiApproved APSL_1_2 = True -licenseIsOsiApproved APSL_2_0 = True -licenseIsOsiApproved Artistic_1_0_cl8 = True -licenseIsOsiApproved Artistic_1_0_Perl = True -licenseIsOsiApproved Artistic_1_0 = True -licenseIsOsiApproved Artistic_2_0 = True -licenseIsOsiApproved BSD_1_Clause = True -licenseIsOsiApproved BSD_2_Clause_Patent = True -licenseIsOsiApproved BSD_2_Clause = True -licenseIsOsiApproved BSD_3_Clause_LBNL = True -licenseIsOsiApproved BSD_3_Clause = True -licenseIsOsiApproved BSL_1_0 = True -licenseIsOsiApproved CAL_1_0_Combined_Work_Exception = True -licenseIsOsiApproved CAL_1_0 = True -licenseIsOsiApproved CATOSL_1_1 = True -licenseIsOsiApproved CDDL_1_0 = True -licenseIsOsiApproved CECILL_2_1 = True -licenseIsOsiApproved CNRI_Python = True -licenseIsOsiApproved CPAL_1_0 = True -licenseIsOsiApproved CPL_1_0 = True -licenseIsOsiApproved CUA_OPL_1_0 = True -licenseIsOsiApproved ECL_1_0 = True -licenseIsOsiApproved ECL_2_0 = True -licenseIsOsiApproved EFL_1_0 = True -licenseIsOsiApproved EFL_2_0 = True -licenseIsOsiApproved Entessa = True -licenseIsOsiApproved EPL_1_0 = True -licenseIsOsiApproved EPL_2_0 = True -licenseIsOsiApproved EUDatagrid = True -licenseIsOsiApproved EUPL_1_1 = True -licenseIsOsiApproved EUPL_1_2 = True -licenseIsOsiApproved Fair = True -licenseIsOsiApproved Frameworx_1_0 = True -licenseIsOsiApproved GPL_2_0_only = True -licenseIsOsiApproved GPL_2_0_or_later = True -licenseIsOsiApproved GPL_3_0_only = True -licenseIsOsiApproved GPL_3_0_or_later = True -licenseIsOsiApproved HPND = True -licenseIsOsiApproved Intel = True -licenseIsOsiApproved IPA = True -licenseIsOsiApproved IPL_1_0 = True -licenseIsOsiApproved ISC = True -licenseIsOsiApproved LGPL_2_0_only = True -licenseIsOsiApproved LGPL_2_0_or_later = True -licenseIsOsiApproved LGPL_2_1_only = True -licenseIsOsiApproved LGPL_2_1_or_later = True -licenseIsOsiApproved LGPL_3_0_only = True -licenseIsOsiApproved LGPL_3_0_or_later = True -licenseIsOsiApproved LiLiQ_P_1_1 = True -licenseIsOsiApproved LiLiQ_R_1_1 = True -licenseIsOsiApproved LiLiQ_Rplus_1_1 = True -licenseIsOsiApproved LPL_1_02 = True -licenseIsOsiApproved LPL_1_0 = True -licenseIsOsiApproved LPPL_1_3c = True -licenseIsOsiApproved MirOS = True -licenseIsOsiApproved MIT = True -licenseIsOsiApproved Motosoto = True -licenseIsOsiApproved MPL_1_0 = True -licenseIsOsiApproved MPL_1_1 = True -licenseIsOsiApproved MPL_2_0_no_copyleft_exception = True -licenseIsOsiApproved MPL_2_0 = True -licenseIsOsiApproved MS_PL = True -licenseIsOsiApproved MS_RL = True -licenseIsOsiApproved MulanPSL_2_0 = True -licenseIsOsiApproved Multics = True -licenseIsOsiApproved NASA_1_3 = True -licenseIsOsiApproved Naumen = True -licenseIsOsiApproved NCSA = True -licenseIsOsiApproved NGPL = True -licenseIsOsiApproved Nokia = True -licenseIsOsiApproved NPOSL_3_0 = True -licenseIsOsiApproved NTP = True -licenseIsOsiApproved OCLC_2_0 = True -licenseIsOsiApproved OFL_1_1_no_RFN = True -licenseIsOsiApproved OFL_1_1_RFN = True -licenseIsOsiApproved OFL_1_1 = True -licenseIsOsiApproved OGTSL = True -licenseIsOsiApproved OSET_PL_2_1 = True -licenseIsOsiApproved OSL_1_0 = True -licenseIsOsiApproved OSL_2_0 = True -licenseIsOsiApproved OSL_2_1 = True -licenseIsOsiApproved OSL_3_0 = True -licenseIsOsiApproved PHP_3_01 = True -licenseIsOsiApproved PHP_3_0 = True -licenseIsOsiApproved PostgreSQL = True -licenseIsOsiApproved Python_2_0 = True -licenseIsOsiApproved QPL_1_0 = True -licenseIsOsiApproved RPL_1_1 = True -licenseIsOsiApproved RPL_1_5 = True -licenseIsOsiApproved RPSL_1_0 = True -licenseIsOsiApproved RSCPL = True -licenseIsOsiApproved SimPL_2_0 = True -licenseIsOsiApproved SISSL = True -licenseIsOsiApproved Sleepycat = True -licenseIsOsiApproved SPL_1_0 = True -licenseIsOsiApproved UCL_1_0 = True -licenseIsOsiApproved Unlicense = True -licenseIsOsiApproved UPL_1_0 = True -licenseIsOsiApproved VSL_1_0 = True -licenseIsOsiApproved W3C = True -licenseIsOsiApproved Watcom_1_0 = True -licenseIsOsiApproved Xnet = True -licenseIsOsiApproved Zlib = True -licenseIsOsiApproved ZPL_2_0 = True -licenseIsOsiApproved _ = False - --- | Whether the license is considered libre by Free Software Foundation (FSF). --- --- See --- --- @since 3.4.0.0 --- -licenseIsFsfLibre :: LicenseId -> Bool -licenseIsFsfLibre AFL_1_1 = True -licenseIsFsfLibre AFL_1_2 = True -licenseIsFsfLibre AFL_2_0 = True -licenseIsFsfLibre AFL_2_1 = True -licenseIsFsfLibre AFL_3_0 = True -licenseIsFsfLibre AGPL_1_0 = True -licenseIsFsfLibre AGPL_3_0_only = True -licenseIsFsfLibre AGPL_3_0_or_later = True -licenseIsFsfLibre Apache_1_0 = True -licenseIsFsfLibre Apache_1_1 = True -licenseIsFsfLibre Apache_2_0 = True -licenseIsFsfLibre APSL_2_0 = True -licenseIsFsfLibre Artistic_2_0 = True -licenseIsFsfLibre BitTorrent_1_1 = True -licenseIsFsfLibre BSD_2_Clause_FreeBSD = True -licenseIsFsfLibre BSD_3_Clause_Clear = True -licenseIsFsfLibre BSD_3_Clause = True -licenseIsFsfLibre BSD_4_Clause = True -licenseIsFsfLibre BSL_1_0 = True -licenseIsFsfLibre CC_BY_4_0 = True -licenseIsFsfLibre CC_BY_SA_4_0 = True -licenseIsFsfLibre CC0_1_0 = True -licenseIsFsfLibre CDDL_1_0 = True -licenseIsFsfLibre CECILL_2_0 = True -licenseIsFsfLibre CECILL_B = True -licenseIsFsfLibre CECILL_C = True -licenseIsFsfLibre ClArtistic = True -licenseIsFsfLibre Condor_1_1 = True -licenseIsFsfLibre CPAL_1_0 = True -licenseIsFsfLibre CPL_1_0 = True -licenseIsFsfLibre ECL_2_0 = True -licenseIsFsfLibre EFL_2_0 = True -licenseIsFsfLibre EPL_1_0 = True -licenseIsFsfLibre EPL_2_0 = True -licenseIsFsfLibre EUDatagrid = True -licenseIsFsfLibre EUPL_1_1 = True -licenseIsFsfLibre EUPL_1_2 = True -licenseIsFsfLibre FSFAP = True -licenseIsFsfLibre FTL = True -licenseIsFsfLibre GFDL_1_1_only = True -licenseIsFsfLibre GFDL_1_1_or_later = True -licenseIsFsfLibre GFDL_1_2_only = True -licenseIsFsfLibre GFDL_1_2_or_later = True -licenseIsFsfLibre GFDL_1_3_only = True -licenseIsFsfLibre GFDL_1_3_or_later = True -licenseIsFsfLibre Gnuplot = True -licenseIsFsfLibre GPL_2_0_only = True -licenseIsFsfLibre GPL_2_0_or_later = True -licenseIsFsfLibre GPL_3_0_only = True -licenseIsFsfLibre GPL_3_0_or_later = True -licenseIsFsfLibre HPND = True -licenseIsFsfLibre IJG = True -licenseIsFsfLibre IMatix = True -licenseIsFsfLibre Imlib2 = True -licenseIsFsfLibre Intel = True -licenseIsFsfLibre IPA = True -licenseIsFsfLibre IPL_1_0 = True -licenseIsFsfLibre ISC = True -licenseIsFsfLibre LGPL_2_1_only = True -licenseIsFsfLibre LGPL_2_1_or_later = True -licenseIsFsfLibre LGPL_3_0_only = True -licenseIsFsfLibre LGPL_3_0_or_later = True -licenseIsFsfLibre LPL_1_02 = True -licenseIsFsfLibre LPPL_1_2 = True -licenseIsFsfLibre LPPL_1_3a = True -licenseIsFsfLibre MIT = True -licenseIsFsfLibre MPL_1_1 = True -licenseIsFsfLibre MPL_2_0 = True -licenseIsFsfLibre MS_PL = True -licenseIsFsfLibre MS_RL = True -licenseIsFsfLibre NCSA = True -licenseIsFsfLibre Nokia = True -licenseIsFsfLibre NOSL = True -licenseIsFsfLibre NPL_1_0 = True -licenseIsFsfLibre NPL_1_1 = True -licenseIsFsfLibre ODbL_1_0 = True -licenseIsFsfLibre OFL_1_0 = True -licenseIsFsfLibre OFL_1_1 = True -licenseIsFsfLibre OLDAP_2_3 = True -licenseIsFsfLibre OLDAP_2_7 = True -licenseIsFsfLibre OpenSSL = True -licenseIsFsfLibre OSL_1_0 = True -licenseIsFsfLibre OSL_1_1 = True -licenseIsFsfLibre OSL_2_0 = True -licenseIsFsfLibre OSL_2_1 = True -licenseIsFsfLibre OSL_3_0 = True -licenseIsFsfLibre PHP_3_01 = True -licenseIsFsfLibre Python_2_0 = True -licenseIsFsfLibre QPL_1_0 = True -licenseIsFsfLibre RPSL_1_0 = True -licenseIsFsfLibre Ruby = True -licenseIsFsfLibre SGI_B_2_0 = True -licenseIsFsfLibre SISSL = True -licenseIsFsfLibre Sleepycat = True -licenseIsFsfLibre SMLNJ = True -licenseIsFsfLibre SPL_1_0 = True -licenseIsFsfLibre Unlicense = True -licenseIsFsfLibre UPL_1_0 = True -licenseIsFsfLibre Vim = True -licenseIsFsfLibre W3C = True -licenseIsFsfLibre WTFPL = True -licenseIsFsfLibre X11 = True -licenseIsFsfLibre XFree86_1_1 = True -licenseIsFsfLibre Xinetd = True -licenseIsFsfLibre YPL_1_1 = True -licenseIsFsfLibre Zend_2_0 = True -licenseIsFsfLibre Zimbra_1_3 = True -licenseIsFsfLibre Zlib = True -licenseIsFsfLibre ZPL_2_0 = True -licenseIsFsfLibre ZPL_2_1 = True -licenseIsFsfLibre _ = False - -------------------------------------------------------------------------------- --- Creation -------------------------------------------------------------------------------- - -licenseIdList :: LicenseListVersion -> [LicenseId] -licenseIdList LicenseListVersion_3_0 = - [ AGPL_1_0 - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_2 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_6 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_2_Clause_NetBSD - , BSD_3_Clause_Open_MPI - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Linux_OpenIB - , MIT_0 - , ODC_By_1_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_9 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_3_Clause_Open_MPI - , CAL_1_0_Combined_Work_Exception - , CAL_1_0 - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , CERN_OHL_P_2_0 - , CERN_OHL_S_2_0 - , CERN_OHL_W_2_0 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , Etalab_2_0 - , Hippocratic_2_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Libselinux_1_0 - , Linux_OpenIB - , MIT_0 - , MulanPSL_1_0 - , MulanPSL_2_0 - , NCGL_UK_2_0 - , NTP_0 - , O_UDA_1_0 - , ODC_By_1_0 - , OFL_1_0_no_RFN - , OFL_1_0_RFN - , OFL_1_1_no_RFN - , OFL_1_1_RFN - , OGC_1_0 - , OGL_Canada_2_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Parity_7_0_0 - , PolyForm_Noncommercial_1_0_0 - , PolyForm_Small_Business_1_0_0 - , PSF_2_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSH_OpenSSH - , SSH_short - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - , UCL_1_0 - ] - ++ bulkOfLicenses -licenseIdList LicenseListVersion_3_10 = - [ AGPL_1_0_only - , AGPL_1_0_or_later - , Blessing - , BlueOak_1_0_0 - , BSD_2_Clause_FreeBSD - , BSD_3_Clause_Open_MPI - , CAL_1_0_Combined_Work_Exception - , CAL_1_0 - , CC_PDDC - , CERN_OHL_1_1 - , CERN_OHL_1_2 - , CERN_OHL_P_2_0 - , CERN_OHL_S_2_0 - , CERN_OHL_W_2_0 - , Copyleft_next_0_3_0 - , Copyleft_next_0_3_1 - , Etalab_2_0 - , Hippocratic_2_1 - , HPND_sell_variant - , JPNIC - , Libpng_2_0 - , Libselinux_1_0 - , Linux_OpenIB - , MIT_0 - , MulanPSL_1_0 - , MulanPSL_2_0 - , NCGL_UK_2_0 - , NTP_0 - , O_UDA_1_0 - , ODC_By_1_0 - , OFL_1_0_no_RFN - , OFL_1_0_RFN - , OFL_1_1_no_RFN - , OFL_1_1_RFN - , OGC_1_0 - , OGL_Canada_2_0 - , OGL_UK_1_0 - , OGL_UK_2_0 - , OGL_UK_3_0 - , Parity_6_0_0 - , Parity_7_0_0 - , PolyForm_Noncommercial_1_0_0 - , PolyForm_Small_Business_1_0_0 - , PSF_2_0 - , Sendmail_8_23 - , SHL_0_51 - , SHL_0_5 - , SSH_OpenSSH - , SSH_short - , SSPL_1_0 - , TAPR_OHL_1_0 - , TU_Berlin_1_0 - , TU_Berlin_2_0 - , UCL_1_0 - ] - ++ bulkOfLicenses - --- | Create a 'LicenseId' from a 'String'. -mkLicenseId :: LicenseListVersion -> String -> Maybe LicenseId -mkLicenseId LicenseListVersion_3_0 s = Map.lookup s stringLookup_3_0 -mkLicenseId LicenseListVersion_3_2 s = Map.lookup s stringLookup_3_2 -mkLicenseId LicenseListVersion_3_6 s = Map.lookup s stringLookup_3_6 -mkLicenseId LicenseListVersion_3_9 s = Map.lookup s stringLookup_3_9 -mkLicenseId LicenseListVersion_3_10 s = Map.lookup s stringLookup_3_10 - -stringLookup_3_0 :: Map String LicenseId -stringLookup_3_0 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_0 - -stringLookup_3_2 :: Map String LicenseId -stringLookup_3_2 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_2 - -stringLookup_3_6 :: Map String LicenseId -stringLookup_3_6 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_6 - -stringLookup_3_9 :: Map String LicenseId -stringLookup_3_9 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_9 - -stringLookup_3_10 :: Map String LicenseId -stringLookup_3_10 = Map.fromList $ map (\i -> (licenseId i, i)) $ - licenseIdList LicenseListVersion_3_10 - --- | Licenses in all SPDX License lists -bulkOfLicenses :: [LicenseId] -bulkOfLicenses = - [ NullBSD - , AAL - , Abstyles - , Adobe_2006 - , Adobe_Glyph - , ADSL - , AFL_1_1 - , AFL_1_2 - , AFL_2_0 - , AFL_2_1 - , AFL_3_0 - , Afmparse - , AGPL_3_0_only - , AGPL_3_0_or_later - , Aladdin - , AMDPLPA - , AML - , AMPAS - , ANTLR_PD - , Apache_1_0 - , Apache_1_1 - , Apache_2_0 - , APAFML - , APL_1_0 - , APSL_1_0 - , APSL_1_1 - , APSL_1_2 - , APSL_2_0 - , Artistic_1_0_cl8 - , Artistic_1_0_Perl - , Artistic_1_0 - , Artistic_2_0 - , Bahyph - , Barr - , Beerware - , BitTorrent_1_0 - , BitTorrent_1_1 - , Borceux - , BSD_1_Clause - , BSD_2_Clause_Patent - , BSD_2_Clause - , BSD_3_Clause_Attribution - , BSD_3_Clause_Clear - , BSD_3_Clause_LBNL - , BSD_3_Clause_No_Nuclear_License_2014 - , BSD_3_Clause_No_Nuclear_License - , BSD_3_Clause_No_Nuclear_Warranty - , BSD_3_Clause - , BSD_4_Clause_UC - , BSD_4_Clause - , BSD_Protection - , BSD_Source_Code - , BSL_1_0 - , Bzip2_1_0_5 - , Bzip2_1_0_6 - , Caldera - , CATOSL_1_1 - , CC_BY_1_0 - , CC_BY_2_0 - , CC_BY_2_5 - , CC_BY_3_0 - , CC_BY_4_0 - , CC_BY_NC_1_0 - , CC_BY_NC_2_0 - , CC_BY_NC_2_5 - , CC_BY_NC_3_0 - , CC_BY_NC_4_0 - , CC_BY_NC_ND_1_0 - , CC_BY_NC_ND_2_0 - , CC_BY_NC_ND_2_5 - , CC_BY_NC_ND_3_0 - , CC_BY_NC_ND_4_0 - , CC_BY_NC_SA_1_0 - , CC_BY_NC_SA_2_0 - , CC_BY_NC_SA_2_5 - , CC_BY_NC_SA_3_0 - , CC_BY_NC_SA_4_0 - , CC_BY_ND_1_0 - , CC_BY_ND_2_0 - , CC_BY_ND_2_5 - , CC_BY_ND_3_0 - , CC_BY_ND_4_0 - , CC_BY_SA_1_0 - , CC_BY_SA_2_0 - , CC_BY_SA_2_5 - , CC_BY_SA_3_0 - , CC_BY_SA_4_0 - , CC0_1_0 - , CDDL_1_0 - , CDDL_1_1 - , CDLA_Permissive_1_0 - , CDLA_Sharing_1_0 - , CECILL_1_0 - , CECILL_1_1 - , CECILL_2_0 - , CECILL_2_1 - , CECILL_B - , CECILL_C - , ClArtistic - , CNRI_Jython - , CNRI_Python_GPL_Compatible - , CNRI_Python - , Condor_1_1 - , CPAL_1_0 - , CPL_1_0 - , CPOL_1_02 - , Crossword - , CrystalStacker - , CUA_OPL_1_0 - , Cube - , Curl - , D_FSL_1_0 - , Diffmark - , DOC - , Dotseqn - , DSDP - , Dvipdfm - , ECL_1_0 - , ECL_2_0 - , EFL_1_0 - , EFL_2_0 - , EGenix - , Entessa - , EPL_1_0 - , EPL_2_0 - , ErlPL_1_1 - , EUDatagrid - , EUPL_1_0 - , EUPL_1_1 - , EUPL_1_2 - , Eurosym - , Fair - , Frameworx_1_0 - , FreeImage - , FSFAP - , FSFULLR - , FSFUL - , FTL - , GFDL_1_1_only - , GFDL_1_1_or_later - , GFDL_1_2_only - , GFDL_1_2_or_later - , GFDL_1_3_only - , GFDL_1_3_or_later - , Giftware - , GL2PS - , Glide - , Glulxe - , Gnuplot - , GPL_1_0_only - , GPL_1_0_or_later - , GPL_2_0_only - , GPL_2_0_or_later - , GPL_3_0_only - , GPL_3_0_or_later - , GSOAP_1_3b - , HaskellReport - , HPND - , IBM_pibs - , ICU - , IJG - , ImageMagick - , IMatix - , Imlib2 - , Info_ZIP - , Intel_ACPI - , Intel - , Interbase_1_0 - , IPA - , IPL_1_0 - , ISC - , JasPer_2_0 - , JSON - , LAL_1_2 - , LAL_1_3 - , Latex2e - , Leptonica - , LGPL_2_0_only - , LGPL_2_0_or_later - , LGPL_2_1_only - , LGPL_2_1_or_later - , LGPL_3_0_only - , LGPL_3_0_or_later - , LGPLLR - , Libpng - , Libtiff - , LiLiQ_P_1_1 - , LiLiQ_R_1_1 - , LiLiQ_Rplus_1_1 - , LPL_1_02 - , LPL_1_0 - , LPPL_1_0 - , LPPL_1_1 - , LPPL_1_2 - , LPPL_1_3a - , LPPL_1_3c - , MakeIndex - , MirOS - , MIT_advertising - , MIT_CMU - , MIT_enna - , MIT_feh - , MITNFA - , MIT - , Motosoto - , Mpich2 - , MPL_1_0 - , MPL_1_1 - , MPL_2_0_no_copyleft_exception - , MPL_2_0 - , MS_PL - , MS_RL - , MTLL - , Multics - , Mup - , NASA_1_3 - , Naumen - , NBPL_1_0 - , NCSA - , Net_SNMP - , NetCDF - , Newsletr - , NGPL - , NLOD_1_0 - , NLPL - , Nokia - , NOSL - , Noweb - , NPL_1_0 - , NPL_1_1 - , NPOSL_3_0 - , NRL - , NTP - , OCCT_PL - , OCLC_2_0 - , ODbL_1_0 - , OFL_1_0 - , OFL_1_1 - , OGTSL - , OLDAP_1_1 - , OLDAP_1_2 - , OLDAP_1_3 - , OLDAP_1_4 - , OLDAP_2_0_1 - , OLDAP_2_0 - , OLDAP_2_1 - , OLDAP_2_2_1 - , OLDAP_2_2_2 - , OLDAP_2_2 - , OLDAP_2_3 - , OLDAP_2_4 - , OLDAP_2_5 - , OLDAP_2_6 - , OLDAP_2_7 - , OLDAP_2_8 - , OML - , OpenSSL - , OPL_1_0 - , OSET_PL_2_1 - , OSL_1_0 - , OSL_1_1 - , OSL_2_0 - , OSL_2_1 - , OSL_3_0 - , PDDL_1_0 - , PHP_3_01 - , PHP_3_0 - , Plexus - , PostgreSQL - , Psfrag - , Psutils - , Python_2_0 - , Qhull - , QPL_1_0 - , Rdisc - , RHeCos_1_1 - , RPL_1_1 - , RPL_1_5 - , RPSL_1_0 - , RSA_MD - , RSCPL - , Ruby - , SAX_PD - , Saxpath - , SCEA - , Sendmail - , SGI_B_1_0 - , SGI_B_1_1 - , SGI_B_2_0 - , SimPL_2_0 - , SISSL_1_2 - , SISSL - , Sleepycat - , SMLNJ - , SMPPL - , SNIA - , Spencer_86 - , Spencer_94 - , Spencer_99 - , SPL_1_0 - , SugarCRM_1_1_3 - , SWL - , TCL - , TCP_wrappers - , TMate - , TORQUE_1_1 - , TOSL - , Unicode_DFS_2015 - , Unicode_DFS_2016 - , Unicode_TOU - , Unlicense - , UPL_1_0 - , Vim - , VOSTROM - , VSL_1_0 - , W3C_19980720 - , W3C_20150513 - , W3C - , Watcom_1_0 - , Wsuipa - , WTFPL - , X11 - , Xerox - , XFree86_1_1 - , Xinetd - , Xnet - , Xpp - , XSkat - , YPL_1_0 - , YPL_1_1 - , Zed - , Zend_2_0 - , Zimbra_1_3 - , Zimbra_1_4 - , Zlib_acknowledgement - , Zlib - , ZPL_1_1 - , ZPL_2_0 - , ZPL_2_1 - ] diff --git a/src/Distribution/SPDX/LicenseListVersion.hs b/src/Distribution/SPDX/LicenseListVersion.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseListVersion.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.SPDX.LicenseListVersion ( - LicenseListVersion (..), - cabalSpecVersionToSPDXListVersion, - ) where - -import Distribution.CabalSpecVersion - --- | SPDX License List version @Cabal@ is aware of. -data LicenseListVersion - = LicenseListVersion_3_0 - | LicenseListVersion_3_2 - | LicenseListVersion_3_6 - | LicenseListVersion_3_9 - | LicenseListVersion_3_10 - deriving (Eq, Ord, Show, Enum, Bounded) - -cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion -cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10 -cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9 -cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6 -cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2 -cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0 diff --git a/src/Distribution/SPDX/LicenseReference.hs b/src/Distribution/SPDX/LicenseReference.hs deleted file mode 100644 --- a/src/Distribution/SPDX/LicenseReference.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.SPDX.LicenseReference ( - LicenseRef, - licenseRef, - licenseDocumentRef, - mkLicenseRef, - mkLicenseRef', - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (isAsciiAlphaNum) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List); -data LicenseRef = LicenseRef - { _lrDocument :: !(Maybe String) - , _lrLicense :: !String - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | License reference. -licenseRef :: LicenseRef -> String -licenseRef = _lrLicense - --- | Document reference. -licenseDocumentRef :: LicenseRef -> Maybe String -licenseDocumentRef = _lrDocument - -instance Binary LicenseRef -instance Structured LicenseRef - -instance NFData LicenseRef where - rnf (LicenseRef d l) = rnf d `seq` rnf l - -instance Pretty LicenseRef where - pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l - pretty (LicenseRef (Just d) l) = - Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l - -instance Parsec LicenseRef where - parsec = name <|> doc - where - name = do - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef Nothing n) - - doc = do - _ <- P.string "DocumentRef-" - d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - _ <- P.char ':' - _ <- P.string "LicenseRef-" - n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.' - pure (LicenseRef (Just d) n) - --- | Create 'LicenseRef' from optional document ref and name. -mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef -mkLicenseRef d l = do - d' <- traverse checkIdString d - l' <- checkIdString l - pure (LicenseRef d' l') - where - checkIdString s - | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s - | otherwise = Nothing - --- | Like 'mkLicenseRef' but convert invalid characters into @-@. -mkLicenseRef' :: Maybe String -> String -> LicenseRef -mkLicenseRef' d l = LicenseRef (fmap f d) (f l) - where - f = map g - g c | isAsciiAlphaNum c || c == '-' || c == '.' = c - | otherwise = '-' diff --git a/src/Distribution/Simple.hs b/src/Distribution/Simple.hs --- a/src/Distribution/Simple.hs +++ b/src/Distribution/Simple.hs @@ -1,836 +1,1132 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the command line front end to the Simple build system. When given --- the parsed command-line args and package information, is able to perform --- basic commands like configure, build, install, register, etc. --- --- This module exports the main functions that Setup.hs scripts use. It --- re-exports the 'UserHooks' type, the standard entry points like --- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of --- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own --- behaviour. --- --- This module isn't called \"Simple\" because it's simple. Far from --- it. It's called \"Simple\" because it does complicated things to --- simple software. --- --- The original idea was that there could be different build systems that all --- presented the same compatible command line interfaces. There is still a --- "Distribution.Make" system but in practice no packages use it. - -{- -Work around this warning: -libraries/Cabal/Distribution/Simple.hs:78:0: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - emptyUserHooks, - ) where - -import Control.Exception (try) - -import Prelude () -import Distribution.Compat.Prelude - --- local -import Distribution.Simple.Compiler -import Distribution.Simple.UserHooks -import Distribution.Package -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Simple.Program -import Distribution.Simple.Program.Db -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Build -import Distribution.Simple.SrcDist -import Distribution.Simple.Register - -import Distribution.Simple.Configure - -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Bench -import Distribution.Simple.BuildPaths -import Distribution.Simple.Test -import Distribution.Simple.Install -import Distribution.Simple.Haddock -import Distribution.Simple.Utils -import Distribution.Utils.NubList -import Distribution.Verbosity -import Language.Haskell.Extension -import Distribution.Version -import Distribution.License -import Distribution.Pretty -import Distribution.System (buildPlatform) - --- Base -import System.Environment (getArgs, getProgName) -import System.Directory (removeFile, doesFileExist - ,doesDirectoryExist, removeDirectoryRecursive) -import System.FilePath (searchPathSeparator, takeDirectory, (), - splitDirectories, dropDrive) -#ifdef mingw32_HOST_OS -import System.FilePath (normalise, splitDrive) -#endif -import Distribution.Compat.ResponseFile (expandResponse) -import Distribution.Compat.Directory (makeAbsolute) -import Distribution.Compat.Environment (getEnvironment) -import Distribution.Compat.GetShortPathName (getShortPathName) - -import Data.List (unionBy, (\\)) - -import Distribution.PackageDescription.Parsec - --- | A simple implementation of @main@ for a Cabal setup script. --- It reads the package description file using IO, and performs the --- action specified on the command line. -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainHelper simpleUserHooks - --- | A version of 'defaultMain' that is passed the command line --- arguments, rather than getting them from the environment. -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper simpleUserHooks - --- | A customizable version of 'defaultMain'. -defaultMainWithHooks :: UserHooks -> IO () -defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks - --- | A customizable version of 'defaultMain' that also takes the command --- line arguments. -defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () -defaultMainWithHooksArgs = defaultMainHelper - --- | Like 'defaultMain', but accepts the package description as input --- rather than using IO to read it. -defaultMainNoRead :: GenericPackageDescription -> IO () -defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks - --- | A customizable version of 'defaultMainNoRead'. -defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () -defaultMainWithHooksNoRead hooks pkg_descr = - getArgs >>= - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } - --- | A customizable version of 'defaultMainNoRead' that also takes the --- command line arguments. --- --- @since 2.2.0.0 -defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () -defaultMainWithHooksNoReadArgs hooks pkg_descr = - defaultMainHelper hooks { readDesc = return (Just pkg_descr) } - -defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler $ do - args' <- expandResponse args - case commandsRun (globalCommand commands) commands args' of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (intercalate "\n" errs) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ prettyShow cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ prettyShow cabalVersion - - progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb - commands = - [configureCommand progs `commandAddAction` - \fs as -> configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,showBuildInfoCommand progs `commandAddAction` showBuildInfoAction hooks - ,replCommand progs `commandAddAction` replAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ,benchmarkCommand `commandAddAction` benchAction hooks - ] - --- | Combine the preprocessors in the given hooks with the --- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) - -configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction hooks flags args = do - distPref <- findDistPrefOrDefault (configDistPref flags) - let flags' = flags { configDistPref = toFlag distPref - , configArgs = args } - - -- See docs for 'HookedBuildInfo' - pbi <- preConf hooks args flags' - - (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity - (flagToMaybe (configCabalFilePath flags)) - - let epkg_descr = (pkg_descr0, pbi) - - localbuildinfo0 <- confHook hooks epkg_descr flags' - - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo - - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags' pkg_descr localbuildinfo - return localbuildinfo - where - verbosity = fromFlag (configVerbosity flags) - -confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath - -> IO (Maybe FilePath, GenericPackageDescription) -confPkgDescr hooks verbosity mb_path = do - mdescr <- readDesc hooks - case mdescr of - Just descr -> return (Nothing, descr) - Nothing -> do - pdfile <- case mb_path of - Nothing -> defaultPackageDesc verbosity - Just path -> return path - info verbosity "Using Parsec parser" - descr <- readGenericPackageDescription verbosity pdfile - return (Just pdfile, descr) - -buildAction :: UserHooks -> BuildFlags -> Args -> IO () -buildAction hooks flags args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) - - hookedAction verbosity preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags' { buildArgs = args } args - -showBuildInfoAction :: UserHooks -> ShowBuildInfoFlags -> Args -> IO () -showBuildInfoAction hooks (ShowBuildInfoFlags flags fileOutput) args = do - distPref <- findDistPrefOrDefault (buildDistPref flags) - let verbosity = fromFlag $ buildVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { buildDistPref = toFlag distPref - , buildCabalFilePath = maybeToFlag (cabalFilePath lbi) - } - - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags') - (buildProgramArgs flags') - (withPrograms lbi) - - pbi <- preBuild hooks args flags' - let lbi' = lbi { withPrograms = progs } - pkg_descr0 = localPkgDescr lbi' - pkg_descr = updatePackageDescription pbi pkg_descr0 - -- TODO: Somehow don't ignore build hook? - buildInfoString <- showBuildInfo pkg_descr lbi' flags - - case fileOutput of - Nothing -> putStr buildInfoString - Just fp -> writeFile fp buildInfoString - - postBuild hooks args flags' pkg_descr lbi' - -replAction :: UserHooks -> ReplFlags -> Args -> IO () -replAction hooks flags args = do - distPref <- findDistPrefOrDefault (replDistPref flags) - let verbosity = fromFlag $ replVerbosity flags - flags' = flags { replDistPref = toFlag distPref } - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (replProgramPaths flags') - (replProgramArgs flags') - (withPrograms lbi) - - -- As far as I can tell, the only reason this doesn't use - -- 'hookedActionWithArgs' is because the arguments of 'replHook' - -- takes the args explicitly. UGH. -- ezyang - pbi <- preRepl hooks args flags' - let pkg_descr0 = localPkgDescr lbi - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi' = lbi { withPrograms = progs - , localPkgDescr = pkg_descr } - replHook hooks pkg_descr lbi' hooks flags' args - postRepl hooks args flags' pkg_descr lbi' - -hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction hooks flags args = do - distPref <- findDistPrefOrDefault (hscolourDistPref flags) - let verbosity = fromFlag $ hscolourVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { hscolourDistPref = toFlag distPref - , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - hookedAction verbosity preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args = do - distPref <- findDistPrefOrDefault (haddockDistPref flags) - let verbosity = fromFlag $ haddockVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { haddockDistPref = toFlag distPref - , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)} - - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags') - (haddockProgramArgs flags') - (withPrograms lbi) - - hookedAction verbosity preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags' { haddockArgs = args } args - -cleanAction :: UserHooks -> CleanFlags -> Args -> IO () -cleanAction hooks flags args = do - distPref <- findDistPrefOrDefault (cleanDistPref flags) - - elbi <- tryGetBuildConfig hooks verbosity distPref - let flags' = flags { cleanDistPref = toFlag distPref - , cleanCabalFilePath = case elbi of - Left _ -> mempty - Right lbi -> maybeToFlag (cabalFilePath lbi)} - - pbi <- preClean hooks args flags' - - (_, ppd) <- confPkgDescr hooks verbosity Nothing - -- It might seem like we are doing something clever here - -- but we're really not: if you look at the implementation - -- of 'clean' in the end all the package description is - -- used for is to clear out @extra-tmp-files@. IMO, - -- the configure script goo should go into @dist@ too! - -- -- ezyang - let pkg_descr0 = flattenPackageDescription ppd - -- We don't sanity check for clean as an error - -- here would prevent cleaning: - --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - cleanHook hooks pkg_descr () hooks flags' - postClean hooks args flags' pkg_descr () - where - verbosity = fromFlag (cleanVerbosity flags) - -copyAction :: UserHooks -> CopyFlags -> Args -> IO () -copyAction hooks flags args = do - distPref <- findDistPrefOrDefault (copyDistPref flags) - let verbosity = fromFlag $ copyVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { copyDistPref = toFlag distPref - , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags' { copyArgs = args } args - -installAction :: UserHooks -> InstallFlags -> Args -> IO () -installAction hooks flags args = do - distPref <- findDistPrefOrDefault (installDistPref flags) - let verbosity = fromFlag $ installVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { installDistPref = toFlag distPref - , installCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags' args - --- Since Cabal-3.4 UserHooks are completely ignored -sdistAction :: UserHooks -> SDistFlags -> Args -> IO () -sdistAction _hooks flags _args = do - (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing - let pkg_descr = flattenPackageDescription ppd - sdist pkg_descr flags srcPref knownSuffixHandlers - where - verbosity = fromFlag (sDistVerbosity flags) - -testAction :: UserHooks -> TestFlags -> Args -> IO () -testAction hooks flags args = do - distPref <- findDistPrefOrDefault (testDistPref flags) - let verbosity = fromFlag $ testVerbosity flags - flags' = flags { testDistPref = toFlag distPref } - - hookedActionWithArgs verbosity preTest testHook postTest - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO () -benchAction hooks flags args = do - distPref <- findDistPrefOrDefault (benchmarkDistPref flags) - let verbosity = fromFlag $ benchmarkVerbosity flags - flags' = flags { benchmarkDistPref = toFlag distPref } - hookedActionWithArgs verbosity preBench benchHook postBench - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -registerAction :: UserHooks -> RegisterFlags -> Args -> IO () -registerAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags' { regArgs = args } args - -unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction hooks flags args = do - distPref <- findDistPrefOrDefault (regDistPref flags) - let verbosity = fromFlag $ regVerbosity flags - lbi <- getBuildConfig hooks verbosity distPref - let flags' = flags { regDistPref = toFlag distPref - , regCabalFilePath = maybeToFlag (cabalFilePath lbi)} - hookedAction verbosity preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -hookedAction - :: Verbosity - -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedAction verbosity pre_hook cmd_hook = - hookedActionWithArgs verbosity pre_hook - (\h _ pd lbi uh flags -> - cmd_hook h pd lbi uh flags) - -hookedActionWithArgs - :: Verbosity - -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedActionWithArgs verbosity pre_hook cmd_hook post_hook - get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - lbi0 <- get_build_config - let pkg_descr0 = localPkgDescr lbi0 - sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi - let pkg_descr = updatePackageDescription pbi pkg_descr0 - lbi = lbi0 { localPkgDescr = pkg_descr } - cmd_hook hooks args pkg_descr lbi hooks flags - post_hook hooks args flags pkg_descr lbi - -sanityCheckHookedBuildInfo - :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () -sanityCheckHookedBuildInfo verbosity - (PackageDescription { library = Nothing }) (Just _,_) - = die' verbosity $ "The buildinfo contains info for a library, " - ++ "but the package does not have a library." - -sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) - | exe1 : _ <- nonExistant - = die' verbosity $ "The buildinfo contains info for an executable called '" - ++ prettyShow exe1 ++ "' but the package does not have a " - ++ "executable with that name." - where - pkgExeNames = nub (map exeName (executables pkg_descr)) - hookExeNames = nub (map fst hookExes) - nonExistant = hookExeNames \\ pkgExeNames - -sanityCheckHookedBuildInfo _ _ _ = return () - --- | Try to read the 'localBuildInfoFile' -tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetBuildConfig u v = try . getBuildConfig u v - - --- | Read the 'localBuildInfoFile' or throw an exception. -getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo -getBuildConfig hooks verbosity distPref = do - lbi_wo_programs <- getPersistBuildConfig distPref - -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } - - case pkgDescrFile lbi of - Nothing -> return lbi - Just pkg_descr_file -> do - outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file - if outdated - then reconfigure pkg_descr_file lbi - else return lbi - - where - reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo - reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" - let cFlags = configFlags lbi - let cFlags' = cFlags { - -- Since the list of unconfigured programs is not serialized, - -- restore it to the same value as normally used at the beginning - -- of a configure run: - configPrograms_ = fmap (restoreProgramDb - (builtinPrograms ++ hookedPrograms hooks)) - `fmap` configPrograms_ cFlags, - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } - configureAction hooks cFlags' (extraConfigArgs lbi) - - --- -------------------------------------------------------------------------- --- Cleaning - -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do - let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing - - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) - - -- Any extra files the user wants to remove - traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr) - - -- If the user wanted to save the config, write it back - traverse_ (writePersistBuildConfig distPref) maybeConfig - - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else when isFile $ removeFile fname - verbosity = fromFlag (cleanVerbosity flags) - --- -------------------------------------------------------------------------- --- Default hooks - --- | Hooks that correspond to a plain instantiation of the --- \"simple\" build system -simpleUserHooks :: UserHooks -simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - replHook = defaultReplHook, - copyHook = \desc lbi _ f -> install desc lbi f, - -- 'install' has correct 'copy' behavior with params - testHook = defaultTestHook, - benchHook = defaultBenchHook, - instHook = defaultInstallHook, - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } - where - finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) - where - verbosity = fromFlag (configVerbosity flags) - --- | Basic autoconf 'UserHooks': --- --- * 'postConf' runs @.\/configure@, if present. --- --- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', --- 'preReg' and 'preUnreg' read additional build information from --- /package/@.buildinfo@, if present. --- --- Thus @configure@ can use local system information to generate --- /package/@.buildinfo@ and possibly other files. - -autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath, - preCopy = readHookWithArgs copyVerbosity copyDistPref, - preClean = readHook cleanVerbosity cleanDistPref, - preInst = readHook installVerbosity installDistPref, - preHscolour = readHook hscolourVerbosity hscolourDistPref, - preHaddock = readHookWithArgs haddockVerbosity haddockDistPref, - preReg = readHook regVerbosity regDistPref, - preUnreg = readHook regVerbosity regDistPref - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription - -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - baseDir lbi' = fromMaybe "" - (takeDirectory <$> cabalFilePath lbi') - confExists <- doesFileExist $ (baseDir lbi) "configure" - if confExists - then runConfigureScript verbosity - backwardsCompatHack flags lbi - else die' verbosity "configure script not found." - - pbi <- getHookedBuildInfo verbosity (buildDir lbi) - sanityCheckHookedBuildInfo verbosity pkg_descr pbi - let pkg_descr' = updatePackageDescription pbi pkg_descr - lbi' = lbi { localPkgDescr = pkg_descr' } - postConf simpleUserHooks args flags pkg_descr' lbi' - - backwardsCompatHack = False - - readHookWithArgs :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a - -> IO HookedBuildInfo - readHookWithArgs get_verbosity get_dist_pref _ flags = do - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) - - readHook :: (a -> Flag Verbosity) - -> (a -> Flag FilePath) - -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity get_dist_pref a flags = do - noExtraFlags a - dist_dir <- findDistPrefOrDefault (get_dist_pref flags) - getHookedBuildInfo verbosity (dist_dir "build") - where - verbosity = fromFlag (get_verbosity flags) - -runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo - -> IO () -runConfigureScript verbosity backwardsCompatHack flags lbi = do - env <- getEnvironment - let programDb = withPrograms lbi - (ccProg, ccFlags) <- configureCCompiler verbosity programDb - ccProgShort <- getShortPathName ccProg - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - configureFile <- makeAbsolute $ - fromMaybe "." (takeDirectory <$> cabalFilePath lbi) "configure" - -- autoconf is fussy about filenames, and has a set of forbidden - -- characters that can't appear in the build directory, etc: - -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions - -- - -- This has caused hard-to-debug failures in the past (#5368), so we - -- detect some cases early and warn with a clear message. Windows's - -- use of backslashes is problematic here, so we'll switch to - -- slashes, but we do still want to fail on backslashes in POSIX - -- paths. - -- - -- TODO: We don't check for colons, tildes or leading dashes. We - -- also should check the builddir's path, destdir, and all other - -- paths as well. - let configureFile' = toUnix configureFile - for_ badAutoconfCharacters $ \(c, cname) -> - when (c `elem` dropDrive configureFile') $ - warn verbosity $ concat - [ "The path to the './configure' script, '", configureFile' - , "', contains the character '", [c], "' (", cname, ")." - , " This may cause the script to fail with an obscure error, or for" - , " building the package to fail later." - ] - - let extraPath = fromNubList $ configProgramPathExtra flags - let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) - $ lookup "CFLAGS" env - spSep = [searchPathSeparator] - pathEnv = maybe (intercalate spSep extraPath) - ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env - overEnv = ("CFLAGS", Just cflagsEnv) : - [("PATH", Just pathEnv) | not (null extraPath)] - hp = hostPlatform lbi - maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)] - args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag - shProg = simpleProgram "sh" - progDb = modifyProgramSearchPath - (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb - shConfiguredProg <- lookupProgram shProg - `fmap` configureProgram verbosity shProg progDb - case shConfiguredProg of - Just sh -> runProgramInvocation verbosity $ - (programInvocation (sh {programOverrideEnv = overEnv}) args') - { progInvokeCwd = Just (buildDir lbi) } - Nothing -> die' verbosity notFoundMsg - where - args = configureArgs backwardsCompatHack flags - - notFoundMsg = "The package has a './configure' script. " - ++ "If you are on Windows, This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. " - ++ "If you are not on Windows, ensure that an 'sh' command " - ++ "is discoverable in your path." - --- | Convert Windows path to Unix ones -toUnix :: String -> String -#ifdef mingw32_HOST_OS -toUnix s = let tmp = normalise s - (l, rest) = case splitDrive tmp of - ([], x) -> ("/" , x) - (h:_, x) -> ('/':h:"/", x) - parts = splitDirectories rest - in l ++ intercalate "/" parts -#else -toUnix s = intercalate "/" $ splitDirectories s -#endif - -badAutoconfCharacters :: [(Char, String)] -badAutoconfCharacters = - [ (' ', "space") - , ('\t', "tab") - , ('\n', "newline") - , ('\0', "null") - , ('"', "double quote") - , ('#', "hash") - , ('$', "dollar sign") - , ('&', "ampersand") - , ('\'', "single quote") - , ('(', "left bracket") - , (')', "right bracket") - , ('*', "star") - , (';', "semicolon") - , ('<', "less-than sign") - , ('=', "equals sign") - , ('>', "greater-than sign") - , ('?', "question mark") - , ('[', "left square bracket") - , ('\\', "backslash") - , ('`', "backtick") - , ('|', "pipe") - ] - -getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo -getHookedBuildInfo verbosity build_dir = do - maybe_infoFile <- findHookedPackageDesc verbosity build_dir - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> do - info verbosity $ "Reading parameters from " ++ infoFile - readHookedBuildInfo verbosity infoFile - -defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () -defaultTestHook args pkg_descr localbuildinfo _ flags = - test args pkg_descr localbuildinfo flags - -defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo - -> UserHooks -> BenchmarkFlags -> IO () -defaultBenchHook args pkg_descr localbuildinfo _ flags = - bench args pkg_descr localbuildinfo flags - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = installDest flags, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - -defaultReplHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> ReplFlags -> [String] -> IO () -defaultReplHook pkg_descr localbuildinfo hooks flags args = - repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args - -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage (fromFlag (regVerbosity flags)) - "Package contains no library to register:" (packageId pkg_descr) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. +module Distribution.Simple + ( module Distribution.Package + , module Distribution.Version + , module Distribution.License + , module Distribution.Simple.Compiler + , module Language.Haskell.Extension + + -- * Simple interface + , defaultMain + , defaultMainNoRead + , defaultMainArgs + + -- * Customization + , UserHooks (..) + , Args + , defaultMainWithHooks + , defaultMainWithSetupHooks + , defaultMainWithSetupHooksArgs + , defaultMainWithHooksArgs + , defaultMainWithHooksNoRead + , defaultMainWithHooksNoReadArgs + + -- ** Standard sets of hooks + , simpleUserHooks + , autoconfUserHooks + , autoconfSetupHooks + , emptyUserHooks + ) where + +import Control.Exception (try) + +import Distribution.Compat.Prelude +import Distribution.Compat.ResponseFile (expandResponse) +import Prelude () + +-- local + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Simple.Command +import Distribution.Simple.Compiler +import Distribution.Simple.PackageDescription +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Setup +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.UserHooks + +import Distribution.Simple.Build +import Distribution.Simple.Register +import Distribution.Simple.SrcDist + +import Distribution.Simple.Configure + +import Distribution.License +import Distribution.Pretty +import Distribution.Simple.Bench +import Distribution.Simple.BuildPaths +import Distribution.Simple.ConfigureScript (runConfigureScript) +import Distribution.Simple.Errors +import Distribution.Simple.Haddock +import Distribution.Simple.Install +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.SetupHooks.Internal + ( SetupHooks + ) +import Distribution.Simple.Test +import Distribution.Simple.Utils +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension + +-- Base +import Data.List (unionBy, (\\)) +import System.Directory + ( doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + , removeFile + ) +import System.Environment (getArgs, getProgName) + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +defaultMainWithSetupHooks :: SetupHooks -> IO () +defaultMainWithSetupHooks setup_hooks = + getArgs >>= defaultMainWithSetupHooksArgs setup_hooks + +defaultMainWithSetupHooksArgs :: SetupHooks -> [String] -> IO () +defaultMainWithSetupHooksArgs setupHooks = + defaultMainHelper $ + simpleUserHooks + { confHook = setup_confHook + , buildHook = setup_buildHook + , copyHook = setup_copyHook + , instHook = setup_installHook + , replHook = setup_replHook + , haddockHook = setup_haddockHook + , hscolourHook = setup_hscolourHook + } + where + setup_confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + setup_confHook = + configure_setupHooks + (SetupHooks.configureHooks setupHooks) + + setup_buildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () + setup_buildHook pkg_descr lbi hooks flags = + build_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + + setup_copyHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> CopyFlags + -> IO () + setup_copyHook pkg_descr lbi _hooks flags = + install_setupHooks + (SetupHooks.installHooks setupHooks) + pkg_descr + lbi + flags + + setup_installHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () + setup_installHook = + defaultInstallHook_setupHooks + (SetupHooks.installHooks setupHooks) + + setup_replHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () + setup_replHook pkg_descr lbi hooks flags args = + repl_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + flags + (allSuffixHandlers hooks) + args + + setup_haddockHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HaddockFlags + -> IO () + setup_haddockHook pkg_descr lbi hooks flags = + haddock_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + + setup_hscolourHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> HscolourFlags + -> IO () + setup_hscolourHook pkg_descr lbi hooks flags = + hscolour_setupHooks + (SetupHooks.buildHooks setupHooks) + pkg_descr + lbi + (allSuffixHandlers hooks) + flags + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks + +-- | A customizable version of 'defaultMainNoRead'. +defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO () +defaultMainWithHooksNoRead hooks pkg_descr = + getArgs + >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)} + +-- | A customizable version of 'defaultMainNoRead' that also takes the +-- command line arguments. +-- +-- @since 2.2.0.0 +defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO () +defaultMainWithHooksNoReadArgs hooks pkg_descr = + defaultMainHelper hooks{readDesc = return (Just pkg_descr)} + +-- | The central command chooser of the Simple build system, +-- with other defaultMain functions acting as exposed callers, +-- and with 'topHandler' operating as an exceptions handler. +-- +-- This uses 'expandResponse' to read response files, preprocessing +-- response files given by "@" prefixes. +-- +-- Given hooks and args, this runs 'commandsRun' onto the args, +-- getting 'CommandParse' data back, which is then pattern-matched into +-- IO actions for execution, with arguments applied by the parser. +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ do + args' <- expandResponse args + command <- commandsRun (globalCommand commands) commands args' + case command of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ + | fromFlag (globalVersion globalFlags) -> printVersion + | fromFlag (globalNumericVersion globalFlags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalFlags + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (intercalate "\n" errs) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ prettyShow cabalVersion + printVersion = + putStrLn $ + "Cabal library version " + ++ prettyShow cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb + addAction :: CommandUI flags -> (GlobalFlags -> UserHooks -> flags -> [String] -> IO res) -> Command (GlobalFlags -> IO ()) + addAction cmd action = + cmd `commandAddAction` \flags as globalFlags -> void $ action globalFlags hooks flags as + commands :: [Command (GlobalFlags -> IO ())] + commands = + [ configureCommand progs `addAction` configureAction + , buildCommand progs `addAction` buildAction + , replCommand progs `addAction` replAction + , installCommand `addAction` installAction + , copyCommand `addAction` copyAction + , haddockCommand `addAction` haddockAction + , cleanCommand `addAction` cleanAction + , sdistCommand `addAction` sdistAction + , hscolourCommand `addAction` hscolourAction + , registerCommand `addAction` registerAction + , unregisterCommand `addAction` unregisterAction + , testCommand `addAction` testAction + , benchmarkCommand `addAction` benchAction + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers + :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks = + overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: GlobalFlags -> UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction globalFlags hooks flags args = do + distPref <- findDistPrefOrDefault (setupDistPref $ configCommonFlags flags) + let commonFlags = configCommonFlags flags + commonFlags' = + commonFlags + { setupDistPref = toFlag distPref + , setupWorkingDir = globalWorkingDir globalFlags <> setupWorkingDir commonFlags + , setupTargets = args + } + flags' = + flags + { configCommonFlags = commonFlags' + } + mbWorkDir = flagToMaybe $ setupWorkingDir commonFlags' + verbosity = fromFlag $ setupVerbosity commonFlags' + + -- See docs for 'HookedBuildInfo' + pbi <- preConf hooks args flags' + + (mb_pd_file, pkg_descr0) <- + confPkgDescr + hooks + verbosity + mbWorkDir + (flagToMaybe (setupCabalFilePath commonFlags')) + + let epkg_descr = (pkg_descr0, pbi) + + lbi1 <- confHook hooks epkg_descr flags' + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = + lbi1 + { pkgDescrFile = mb_pd_file + , extraConfigArgs = args + } + writePersistBuildConfig mbWorkDir distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags' pkg_descr localbuildinfo + return localbuildinfo + +confPkgDescr + :: UserHooks + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> Maybe (SymbolicPath Pkg File) + -> IO (Maybe (SymbolicPath Pkg File), GenericPackageDescription) +confPkgDescr hooks verbosity cwd mb_path = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- case mb_path of + Nothing -> relativeSymbolicPath <$> tryFindPackageDesc verbosity cwd + Just path -> return path + info verbosity "Using Parsec parser" + descr <- readGenericPackageDescription verbosity cwd pdfile + return (Just pdfile, descr) + +getCommonFlags + :: GlobalFlags + -> UserHooks + -> CommonSetupFlags + -> Args + -> IO (LocalBuildInfo, CommonSetupFlags) +getCommonFlags globalFlags hooks commonFlags args = do + distPref <- findDistPrefOrDefault (setupDistPref commonFlags) + let verbosity = fromFlag $ setupVerbosity commonFlags + lbi <- getBuildConfig globalFlags hooks verbosity distPref + let common' = configCommonFlags $ configFlags lbi + return $ + ( lbi + , commonFlags + { setupDistPref = toFlag distPref + , setupCabalFilePath = setupCabalFilePath common' <> setupCabalFilePath commonFlags + , setupWorkingDir = + globalWorkingDir globalFlags + <> setupWorkingDir common' + <> setupWorkingDir commonFlags + , setupTargets = args + } + ) + +buildAction :: GlobalFlags -> UserHooks -> BuildFlags -> Args -> IO () +buildAction globalFlags hooks flags args = do + let common = buildCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{buildCommonFlags = common'} + + progs <- + reconfigurePrograms + verbosity + (buildProgramPaths flags') + (buildProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preBuild + buildHook + postBuild + (return lbi{withPrograms = progs}) + hooks + flags' + args + +replAction :: GlobalFlags -> UserHooks -> ReplFlags -> Args -> IO () +replAction globalFlags hooks flags args = do + let common = replCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{replCommonFlags = common'} + progs <- + reconfigurePrograms + verbosity + (replProgramPaths flags') + (replProgramArgs flags') + (withPrograms lbi) + + -- As far as I can tell, the only reason this doesn't use + -- 'hookedActionWithArgs' is because the arguments of 'replHook' + -- takes the args explicitly. UGH. -- ezyang + pbi <- preRepl hooks args flags' + let pkg_descr0 = localPkgDescr lbi + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi' = + lbi + { withPrograms = progs + , localPkgDescr = pkg_descr + } + replHook hooks pkg_descr lbi' hooks flags' args + postRepl hooks args flags' pkg_descr lbi' + +hscolourAction :: GlobalFlags -> UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction globalFlags hooks flags args = do + let common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{hscolourCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + + hookedAction + verbosity + preHscolour + hscolourHook + postHscolour + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +haddockAction :: GlobalFlags -> UserHooks -> HaddockFlags -> Args -> IO () +haddockAction globalFlags hooks flags args = do + let common = haddockCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{haddockCommonFlags = common'} + + progs <- + reconfigurePrograms + verbosity + (haddockProgramPaths flags') + (haddockProgramArgs flags') + (withPrograms lbi) + + hookedAction + verbosity + preHaddock + haddockHook + postHaddock + (return lbi{withPrograms = progs}) + hooks + flags' + args + +cleanAction :: GlobalFlags -> UserHooks -> CleanFlags -> Args -> IO () +cleanAction globalFlags hooks flags args = do + let common = cleanCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref <- findDistPrefOrDefault (setupDistPref common) + elbi <- tryGetBuildConfig globalFlags hooks verbosity distPref + let common' = + common + { setupDistPref = toFlag distPref + , setupWorkingDir = case elbi of + Left _ -> + globalWorkingDir globalFlags + <> setupWorkingDir common + Right lbi -> + globalWorkingDir globalFlags + <> setupWorkingDir (configCommonFlags $ configFlags lbi) + <> setupWorkingDir common + , setupCabalFilePath = case elbi of + Left _ -> setupCabalFilePath common + Right lbi -> + setupCabalFilePath common + <> setupCabalFilePath (configCommonFlags $ configFlags lbi) + , setupTargets = args + } + flags' = + flags{cleanCommonFlags = common'} + + mbWorkDirFlag = cleanWorkingDir flags' + mbWorkDir = flagToMaybe mbWorkDirFlag + + pbi <- preClean hooks args flags' + + (_, ppd) <- confPkgDescr hooks verbosity mbWorkDir Nothing + -- It might seem like we are doing something clever here + -- but we're really not: if you look at the implementation + -- of 'clean' in the end all the package description is + -- used for is to clear out @extra-tmp-files@. IMO, + -- the configure script goo should go into @dist@ too! + -- -- ezyang + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags' + postClean hooks args flags' pkg_descr () + +copyAction :: GlobalFlags -> UserHooks -> CopyFlags -> Args -> IO () +copyAction globalFlags hooks flags args = do + let common = copyCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{copyCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preCopy + copyHook + postCopy + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +installAction :: GlobalFlags -> UserHooks -> InstallFlags -> Args -> IO () +installAction globalFlags hooks flags args = do + let common = installCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{installCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preInst + instHook + postInst + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +-- Since Cabal-3.4 UserHooks are completely ignored +sdistAction :: GlobalFlags -> UserHooks -> SDistFlags -> Args -> IO () +sdistAction _globalFlags _hooks flags _args = do + let mbWorkDir = flagToMaybe $ sDistWorkingDir flags + (_, ppd) <- confPkgDescr emptyUserHooks verbosity mbWorkDir Nothing + let pkg_descr = flattenPackageDescription ppd + sdist pkg_descr flags srcPref knownSuffixHandlers + where + verbosity = fromFlag (setupVerbosity $ sDistCommonFlags flags) + +testAction :: GlobalFlags -> UserHooks -> TestFlags -> Args -> IO () +testAction globalFlags hooks flags args = do + let common = testCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{testCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedActionWithArgs + verbosity + preTest + testHook + postTest + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +benchAction :: GlobalFlags -> UserHooks -> BenchmarkFlags -> Args -> IO () +benchAction globalFlags hooks flags args = do + let common = benchmarkCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{benchmarkCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedActionWithArgs + verbosity + preBench + benchHook + postBench + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +registerAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +registerAction globalFlags hooks flags args = do + let common = registerCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{registerCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preReg + regHook + postReg + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +unregisterAction :: GlobalFlags -> UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction globalFlags hooks flags args = do + let common = registerCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + (_lbi, common') <- getCommonFlags globalFlags hooks common args + let flags' = flags{registerCommonFlags = common'} + distPref = fromFlag $ setupDistPref common' + hookedAction + verbosity + preUnreg + unregHook + postUnreg + (getBuildConfig globalFlags hooks verbosity distPref) + hooks + flags' + args + +hookedAction + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> ( UserHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) + -> IO LocalBuildInfo + -> UserHooks + -> flags + -> Args + -> IO () +hookedAction verbosity pre_hook cmd_hook = + hookedActionWithArgs + verbosity + pre_hook + ( \h _ pd lbi uh flags -> + cmd_hook h pd lbi uh flags + ) + +hookedActionWithArgs + :: Verbosity + -> (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> ( UserHooks + -> Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> flags + -> IO () + ) + -> ( UserHooks + -> Args + -> flags + -> PackageDescription + -> LocalBuildInfo + -> IO () + ) + -> IO LocalBuildInfo + -> UserHooks + -> flags + -> Args + -> IO () +hookedActionWithArgs + verbosity + pre_hook + cmd_hook + post_hook + get_build_config + hooks + flags + args = do + pbi <- pre_hook hooks args flags + lbi0 <- get_build_config + let pkg_descr0 = localPkgDescr lbi0 + sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + lbi = lbi0{localPkgDescr = pkg_descr} + cmd_hook hooks args pkg_descr lbi hooks flags + post_hook hooks args flags pkg_descr lbi + +sanityCheckHookedBuildInfo + :: Verbosity -> PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo + verbosity + (PackageDescription{library = Nothing}) + (Just _, _) = + dieWithException verbosity $ NoLibraryForPackage +sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes) + | exe1 : _ <- nonExistant = + dieWithException verbosity $ SanityCheckHookedBuildInfo exe1 + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames +sanityCheckHookedBuildInfo _ _ _ = return () + +-- | Try to read the 'localBuildInfoFile' +tryGetBuildConfig + :: GlobalFlags + -> UserHooks + -> Verbosity + -> SymbolicPath Pkg (Dir Dist) + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetBuildConfig g u v = try . getBuildConfig g u v + +-- | Read the 'localBuildInfoFile' or throw an exception. +getBuildConfig + :: GlobalFlags + -> UserHooks + -> Verbosity + -> SymbolicPath Pkg (Dir Dist) + -> IO LocalBuildInfo +getBuildConfig globalFlags hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig mbWorkDir distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = + lbi_wo_programs + { withPrograms = + restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + where + mbWorkDir = flagToMaybe $ globalWorkingDir globalFlags + reconfigure :: SymbolicPath Pkg File -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ + getSymbolicPath pkg_descr_file + ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = + cFlags + { -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a configure run: + configPrograms_ = + fmap + ( restoreProgramDb + (builtinPrograms ++ hookedPrograms hooks) + ) + `fmap` configPrograms_ cFlags + , configCommonFlags = + (configCommonFlags cFlags) + { -- Use the current, not saved verbosity level: + setupVerbosity = Flag verbosity + } + } + configureAction globalFlags hooks cFlags' (extraConfigArgs lbi) + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let common = cleanCommonFlags flags + verbosity = fromFlag (setupVerbosity common) + distPref = fromFlagOrDefault defaultDistPref $ setupDistPref common + mbWorkDir = flagToMaybe $ setupWorkingDir common + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + distPath = i distPref + notice verbosity "cleaning..." + + maybeConfig <- + if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig mbWorkDir distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPath + when exists (removeDirectoryRecursive distPath) + + -- Any extra files the user wants to remove + traverse_ (removeFileOrDirectory . i) (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + traverse_ (writePersistBuildConfig mbWorkDir distPref) maybeConfig + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir + then removeDirectoryRecursive fname + else when isFile $ removeFile fname + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks + { confHook = configure + , postConf = finalChecks + , buildHook = defaultBuildHook + , replHook = defaultReplHook + , copyHook = \desc lbi _ f -> install desc lbi f + , -- 'install' has correct 'copy' behavior with params + instHook = defaultInstallHook + , testHook = defaultTestHook + , benchHook = defaultBenchHook + , cleanHook = \p _ _ f -> clean p f + , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f + , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f + , regHook = defaultRegHook + , unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (setupVerbosity $ configCommonFlags flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks, except for pre-conf, read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. +autoconfUserHooks :: UserHooks +autoconfUserHooks = + simpleUserHooks + { postConf = defaultPostConf + , preBuild = readHookWithArgs buildCommonFlags + , preRepl = readHookWithArgs replCommonFlags + , preCopy = readHookWithArgs copyCommonFlags + , preClean = readHook cleanCommonFlags + , preInst = readHook installCommonFlags + , preHscolour = readHook hscolourCommonFlags + , preHaddock = readHookWithArgs haddockCommonFlags + , preReg = readHook registerCommonFlags + , preUnreg = readHook registerCommonFlags + , preTest = readHookWithArgs testCommonFlags + , preBench = readHookWithArgs benchmarkCommonFlags + } + where + defaultPostConf + :: Args + -> ConfigFlags + -> PackageDescription + -> LocalBuildInfo + -> IO () + defaultPostConf args flags pkg_descr lbi = + do + let common = configCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + runConfigureScript + flags + (flagAssignment lbi) + (withPrograms lbi) + (hostPlatform lbi) + pbi <- getHookedBuildInfo verbosity mbWorkDir (buildDir lbi) + sanityCheckHookedBuildInfo verbosity pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + lbi' = lbi{localPkgDescr = pkg_descr'} + postConf simpleUserHooks args flags pkg_descr' lbi' + + readHookWithArgs + :: (flags -> CommonSetupFlags) + -> Args + -> flags + -> IO HookedBuildInfo + readHookWithArgs get_common_flags _args flags = do + let common = get_common_flags flags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = flagToMaybe $ setupWorkingDir common + distPref = setupDistPref common + dist_dir <- findDistPrefOrDefault distPref + getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + + readHook + :: (flags -> CommonSetupFlags) + -> Args + -> flags + -> IO HookedBuildInfo + readHook get_common_flags args flags = do + let common = get_common_flags flags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = flagToMaybe $ setupWorkingDir common + distPref = setupDistPref common + noExtraFlags args + dist_dir <- findDistPrefOrDefault distPref + getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + +getHookedBuildInfo + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Build) + -> IO HookedBuildInfo +getHookedBuildInfo verbosity mbWorkDir build_dir = do + maybe_infoFile <- findHookedPackageDesc verbosity mbWorkDir build_dir + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ getSymbolicPath infoFile + readHookedBuildInfo verbosity mbWorkDir infoFile + +autoconfSetupHooks :: SetupHooks +autoconfSetupHooks = + SetupHooks.noSetupHooks + { SetupHooks.configureHooks = + SetupHooks.noConfigureHooks + { SetupHooks.postConfPackageHook = Just post_conf_pkg + , SetupHooks.preConfComponentHook = Just pre_conf_comp + } + } + where + post_conf_pkg + :: SetupHooks.PostConfPackageInputs + -> IO () + post_conf_pkg + ( SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = + LBC.LocalBuildConfig{LBC.withPrograms = progs} + , SetupHooks.packageBuildDescr = + LBC.PackageBuildDescr + { LBC.configFlags = cfg + , LBC.flagAssignment = flags + , LBC.hostPlatform = plat + } + } + ) = runConfigureScript cfg flags progs plat + + pre_conf_comp + :: SetupHooks.PreConfComponentInputs + -> IO SetupHooks.PreConfComponentOutputs + pre_conf_comp + ( SetupHooks.PreConfComponentInputs + { SetupHooks.packageBuildDescr = + LBC.PackageBuildDescr + { LBC.configFlags = cfg + , localPkgDescr = pkg_descr + } + , SetupHooks.component = component + } + ) = do + let verbosity = fromFlag $ configVerbosity cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + distPref = configDistPref cfg + dist_dir <- findDistPrefOrDefault distPref + -- Read the ".buildinfo" file and use that to update + -- the components (main library + executables only). + hbi <- getHookedBuildInfo verbosity mbWorkDir (dist_dir makeRelativePathEx "build") + sanityCheckHookedBuildInfo verbosity pkg_descr hbi + -- SetupHooks TODO: we are reading getHookedBuildInfo once + -- for each component. I think this is inherent to the SetupHooks + -- approach. + let comp_name = componentName component + diff <- case SetupHooks.hookedBuildInfoComponentDiff_maybe hbi comp_name of + Nothing -> return $ SetupHooks.emptyComponentDiff comp_name + Just do_diff -> do_diff + return $ + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } + +defaultTestHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> TestFlags + -> IO () +defaultTestHook args pkg_descr localbuildinfo _ flags = + test args pkg_descr localbuildinfo flags + +defaultBenchHook + :: Args + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BenchmarkFlags + -> IO () +defaultBenchHook args pkg_descr localbuildinfo _ flags = + bench args pkg_descr localbuildinfo flags + +defaultInstallHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook = + defaultInstallHook_setupHooks SetupHooks.noInstallHooks + +defaultInstallHook_setupHooks + :: SetupHooks.InstallHooks + -> PackageDescription + -> LocalBuildInfo + -> UserHooks + -> InstallFlags + -> IO () +defaultInstallHook_setupHooks inst_hooks pkg_descr localbuildinfo _ flags = do + let copyFlags = + defaultCopyFlags + { copyDest = installDest flags + , copyCommonFlags = installCommonFlags flags + } + install_setupHooks inst_hooks pkg_descr localbuildinfo copyFlags + let registerFlags = + defaultRegisterFlags + { regInPlace = installInPlace flags + , regPackageDB = installPackageDB flags + , registerCommonFlags = installCommonFlags flags + } + when (hasLibs pkg_descr) $ + register pkg_descr localbuildinfo registerFlags + +defaultBuildHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> BuildFlags + -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultReplHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> ReplFlags + -> [String] + -> IO () +defaultReplHook pkg_descr localbuildinfo hooks flags args = + repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args + +defaultRegHook + :: PackageDescription + -> LocalBuildInfo + -> UserHooks + -> RegisterFlags + -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else + setupMessage + (fromFlag (setupVerbosity $ registerCommonFlags flags)) + "Package contains no library to register:" + (packageId pkg_descr) diff --git a/src/Distribution/Simple/Bench.hs b/src/Distribution/Simple/Bench.hs --- a/src/Distribution/Simple/Bench.hs +++ b/src/Distribution/Simple/Bench.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Bench -- Copyright : Johan Tibell 2011 @@ -13,113 +15,166 @@ -- This is the entry point into running the benchmarks in a built -- package. It performs the \"@.\/setup bench@\" action. It runs -- benchmarks designated in the package description. - module Distribution.Simple.Bench - ( bench - ) where + ( bench + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Benchmark +import Distribution.Simple.Setup.Common import Distribution.Simple.UserHooks import Distribution.Simple.Utils -import Distribution.Pretty +import Distribution.System (Platform (Platform)) +import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path -import System.Directory ( doesFileExist ) -import System.FilePath ( (), (<.>) ) +import System.Directory (doesFileExist) -- | Perform the \"@.\/setup bench@\" action. -bench :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> BenchmarkFlags -- ^flags sent to benchmark - -> IO () +bench + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> BenchmarkFlags + -- ^ flags sent to benchmark + -> IO () bench args pkg_descr lbi flags = do - let verbosity = fromFlag $ benchmarkVerbosity flags - benchmarkNames = args - pkgBenchmarks = PD.benchmarks pkg_descr - enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi) + curDir <- LBI.absoluteWorkingDirLBI lbi + let verbosity = fromFlag $ benchmarkVerbosity flags + benchmarkNames = args + pkgBenchmarks = PD.benchmarks pkg_descr + enabledBenchmarks = LBI.enabledBenchLBIs pkg_descr lbi + mbWorkDir = flagToMaybe $ benchmarkWorkingDir flags + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path - -- Run the benchmark - doBench :: PD.Benchmark -> IO ExitCode - doBench bm = - case PD.benchmarkInterface bm of - PD.BenchmarkExeV10 _ _ -> do - let cmd = LBI.buildDir lbi name name <.> exeExtension (LBI.hostPlatform lbi) - options = map (benchOption pkg_descr lbi bm) $ - benchmarkOptions flags - -- Check that the benchmark executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ - "Error: Could not find benchmark program \"" - ++ cmd ++ "\". Did you build the package first?" + -- Run the benchmark + doBench :: (PD.Benchmark, LBI.ComponentLocalBuildInfo) -> IO ExitCode + doBench (bm, clbi) = do + let lbiForBench = + lbi + { -- Include any build-tool-depends on build tools internal to the current package. + LBI.withPrograms = + addInternalBuildTools + curDir + pkg_descr + lbi + (benchmarkBuildInfo bm) + (LBI.withPrograms lbi) + } + case PD.benchmarkInterface bm of + PD.BenchmarkExeV10 _ _ -> do + let cmd = i $ LBI.buildDir lbiForBench makeRelativePathEx (name name <.> exeExtension (LBI.hostPlatform lbi)) + options = + map (benchOption pkg_descr lbiForBench bm) $ + benchmarkOptions flags + -- Check that the benchmark executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + NoBenchMarkProgram cmd - notice verbosity $ startMessage name - -- This will redirect the child process - -- stdout/stderr to the parent process. - exitcode <- rawSystemExitCode verbosity cmd options - notice verbosity $ finishMessage name exitcode - return exitcode + -- Compute the appropriate environment for running the benchmark + let progDb = LBI.withPrograms lbiForBench + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + shellEnv <- getFullEnvironment ([("PATH", Just newPath)] ++ envOverrides) - _ -> do - notice verbosity $ "No support for running " - ++ "benchmark " ++ name ++ " of type: " - ++ prettyShow (PD.benchmarkType bm) - exitFailure - where name = unUnqualComponentName $ PD.benchmarkName bm + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbiForBench + then do + let (Platform _ os) = LBI.hostPlatform lbiForBench + paths <- LBI.depLibraryPaths True False lbiForBench clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv - unless (PD.hasBenchmarks pkg_descr) $ do - notice verbosity "Package has no benchmarks." - exitSuccess + notice verbosity $ startMessage name + -- This will redirect the child process + -- stdout/stderr to the parent process. + exitcode <- rawSystemExitCode verbosity mbWorkDir cmd options (Just shellEnv') + notice verbosity $ finishMessage name exitcode + return exitcode + _ -> do + notice verbosity $ + "No support for running " + ++ "benchmark " + ++ name + ++ " of type: " + ++ prettyShow (PD.benchmarkType bm) + exitFailure + where + name = unUnqualComponentName $ PD.benchmarkName bm - when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ - die' verbosity $ "No benchmarks enabled. Did you remember to configure with " - ++ "\'--enable-benchmarks\'?" + unless (PD.hasBenchmarks pkg_descr) $ do + notice verbosity "Package has no benchmarks." + exitSuccess - bmsToRun <- case benchmarkNames of - [] -> return enabledBenchmarks - names -> for names $ \bmName -> - let benchmarkMap = zip enabledNames enabledBenchmarks - enabledNames = map PD.benchmarkName enabledBenchmarks - allNames = map PD.benchmarkName pkgBenchmarks - in case lookup (mkUnqualComponentName bmName) benchmarkMap of - Just t -> return t - _ | mkUnqualComponentName bmName `elem` allNames -> - die' verbosity $ "Package configured with benchmark " - ++ bmName ++ " disabled." - | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName + when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $ + dieWithException verbosity EnableBenchMark - let totalBenchmarks = length bmsToRun - notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." - exitcodes <- traverse doBench bmsToRun - let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) - unless allOk exitFailure + bmsToRun <- case benchmarkNames of + [] -> return enabledBenchmarks + names -> for names $ \bmName -> + let benchmarkMap = zip enabledNames enabledBenchmarks + enabledNames = map (PD.benchmarkName . fst) enabledBenchmarks + allNames = map PD.benchmarkName pkgBenchmarks + in case lookup (mkUnqualComponentName bmName) benchmarkMap of + Just t -> return t + _ + | mkUnqualComponentName bmName `elem` allNames -> + dieWithException verbosity $ BenchMarkNameDisabled bmName + | otherwise -> dieWithException verbosity $ NoBenchMark bmName + + let totalBenchmarks = length bmsToRun + notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..." + exitcodes <- traverse doBench bmsToRun + + let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes) + unless allOk exitFailure where startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n" - finishMessage name exitcode = "Benchmark " ++ name ++ ": " - ++ (case exitcode of - ExitSuccess -> "FINISH" - ExitFailure _ -> "ERROR") - + finishMessage name exitcode = + "Benchmark " + ++ name + ++ ": " + ++ ( case exitcode of + ExitSuccess -> "FINISH" + ExitFailure _ -> "ERROR" + ) -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -benchOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.Benchmark - -> PathTemplate - -> String +benchOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.Benchmark + -> PathTemplate + -> String benchOption pkg_descr lbi bm template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)] diff --git a/src/Distribution/Simple/Build.hs b/src/Distribution/Simple/Build.hs --- a/src/Distribution/Simple/Build.hs +++ b/src/Distribution/Simple/Build.hs @@ -1,734 +1,1240 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Build --- Copyright : Isaac Jones 2003-2005, --- Ross Paterson 2006, --- Duncan Coutts 2007-2008, 2012 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point to actually building the modules in a package. It --- doesn't actually do much itself, most of the work is delegated to --- compiler-specific actions. It does do some non-compiler specific bits like --- running pre-processors. --- - -module Distribution.Simple.Build ( - build, showBuildInfo, repl, - startInterpreter, - - initialBuildSteps, - createInternalPackageDB, - componentInitialBuildSteps, - writeAutogenFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic - -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.ExecutableScope -import Distribution.Types.ForeignLib -import Distribution.Types.LibraryVisibility -import Distribution.Types.LocalBuildInfo -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Types.ModuleRenaming -import Distribution.Types.TargetInfo -import Distribution.Utils.Path - -import Distribution.Package -import Distribution.Backpack -import Distribution.Backpack.DescribeUnitId -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import qualified Distribution.Simple.PackageIndex as Index - -import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) -import Distribution.Simple.Build.PathsModule (generatePathsModule) -import qualified Distribution.Simple.Program.HcPkg as HcPkg - -import Distribution.Simple.Compiler -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.ModuleName as ModuleName - -import Distribution.Simple.Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.PreProcess -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db -import Distribution.Simple.ShowBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Configure -import Distribution.Simple.Register -import Distribution.Simple.Test.LibV09 -import Distribution.Simple.Utils -import Distribution.Simple.Utils.Json - -import Distribution.System -import Distribution.Pretty -import Distribution.Verbosity -import Distribution.Version (thisVersion) - -import Distribution.Compat.Graph (IsNode(..)) - -import Control.Monad -import qualified Data.Set as Set -import System.FilePath ( (), (<.>), takeDirectory ) -import System.Directory ( getCurrentDirectory ) - --- ----------------------------------------------------------------------------- --- |Build the libraries and executables in this package. - -build :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> IO () -build pkg_descr lbi flags suffixes = do - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - info verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - when (null targets) $ - -- Only bother with this message if we're building the whole package - setupMessage verbosity "Building" (packageId pkg_descr) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do - let comp = targetComponent target - clbi = targetCLBI target - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - let bi = componentBuildInfo comp - progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi) - lbi' = lbi { - withPrograms = progs', - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr - lbi' suffixes comp clbi distPref - return (maybe index (Index.insert `flip` index) mb_ipi) - return () - where - distPref = fromFlag (buildDistPref flags) - verbosity = fromFlag (buildVerbosity flags) - - -showBuildInfo :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build - -> IO String -showBuildInfo pkg_descr lbi flags = do - let verbosity = fromFlag (buildVerbosity flags) - targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags) - let targetsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) - doc = mkBuildInfo pkg_descr lbi flags targetsToBuild - return $ renderJson doc "" - - -repl :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> ReplFlags -- ^ Flags that the user passed to build - -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling - -> [String] - -> IO () -repl pkg_descr lbi flags suffixes args = do - let distPref = fromFlag (replDistPref flags) - verbosity = fromFlag (replVerbosity flags) - - target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of - -- This seems DEEPLY questionable. - [] -> case allTargetsInBuildOrder' pkg_descr lbi of - (target:_) -> return target - [] -> die' verbosity $ "Failed to determine target." - [target] -> return target - _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once." - let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] - debug verbosity $ "Component build order: " - ++ intercalate ", " - (map (showComponentName . componentLocalName . targetCLBI) - componentsToBuild) - - internalPackageDB <- createInternalPackageDB verbosity lbi distPref - - let lbiForComponent comp lbi' = - lbi' { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - withPrograms = addInternalBuildTools pkg_descr lbi' - (componentBuildInfo comp) (withPrograms lbi') - } - - -- build any dependent components - sequence_ - [ do let clbi = targetCLBI subtarget - comp = targetComponent subtarget - lbi' = lbiForComponent comp lbi - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - buildComponent verbosity NoFlag - pkg_descr lbi' suffixes comp clbi distPref - | subtarget <- safeInit componentsToBuild ] - - -- REPL for target components - let clbi = targetCLBI target - comp = targetComponent target - lbi' = lbiForComponent comp lbi - replFlags = replReplOptions flags - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref - - --- | Start an interpreter without loading any package files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity programDb comp platform packageDBs = - case compilerFlavor comp of - GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs - GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs - _ -> die' verbosity "A REPL is not supported with this compiler." - -buildComponent :: Verbosity - -> Flag (Maybe Int) - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO (Maybe InstalledPackageInfo) -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CLib lib) clbi distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = flip addExtraAsmSources extras - $ flip addExtraCmmSources extras - $ flip addExtraCxxSources extras - $ flip addExtraCSources extras - $ libbi - } - - buildLib verbosity numJobs pkg_descr lbi lib' clbi - - let oneComponentRequested (OneComponentRequestedSpec _) = True - oneComponentRequested _ = False - -- Don't register inplace if we're only building a single component; - -- it's not necessary because there won't be any subsequent builds - -- that need to tag us - if (not (oneComponentRequested (componentEnabledSpec lbi))) - then do - -- Register the library in-place, so exes can depend - -- on internally defined libraries. - pwd <- getCurrentDirectory - let -- The in place registration uses the "-inplace" suffix, not an ABI hash - installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr - -- NB: Use a fake ABI hash to avoid - -- needing to recompute it every build. - (mkAbiHash "inplace") lib' lbi clbi - - debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) installedPkgInfo - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - return (Just installedPkgInfo) - else return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CFLib flib) clbi _distPref = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildFLib verbosity numJobs pkg_descr lbi flib clbi - return Nothing - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity numJobs pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi -- This ComponentLocalBuildInfo corresponds to a detailed - -- test suite and not a real component. It should not - -- be used, except to construct the CLBIs for the - -- library and stub executable that will actually be - -- built. - distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - buildLib verbosity numJobs pkg lbi lib libClbi - -- NB: need to enable multiple instances here, because on 7.10+ - -- the package name is the same as the library, and we still - -- want the registration to go through. - registerPackage verbosity (compiler lbi) (withPrograms lbi) - (withPackageDB lbi) ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - let ebi = buildInfo exe - -- NB: The stub executable is linked against the test-library - -- which already contains all `other-modules`, so we need - -- to remove those from the stub-exe's build-info - exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } } - buildExe verbosity numJobs pkg_descr lbi exe' exeClbi - return Nothing -- Can't depend on test suite - - -buildComponent verbosity _ _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -buildComponent verbosity numJobs pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - setupMessage' verbosity "Building" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - let ebi = buildInfo exe - exe' = exe { buildInfo = addExtraCSources ebi extras } - buildExe verbosity numJobs pkg_descr lbi exe' clbi - return Nothing - - -buildComponent verbosity _ _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - - --- | Add extra C sources generated by preprocessing to build --- information. -addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCSources bi extras = bi { cSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cSources bi - exs = Set.fromList extras - - --- | Add extra C++ sources generated by preprocessing to build --- information. -addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCxxSources bi extras = bi { cxxSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cxxSources bi - exs = Set.fromList extras - - --- | Add extra C-- sources generated by preprocessing to build --- information. -addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraCmmSources bi extras = bi { cmmSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ cmmSources bi - exs = Set.fromList extras - - --- | Add extra ASM sources generated by preprocessing to build --- information. -addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo -addExtraAsmSources bi extras = bi { asmSources = new } - where new = Set.toList $ old `Set.union` exs - old = Set.fromList $ asmSources bi - exs = Set.fromList extras - - -replComponent :: [String] - -> Verbosity - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> Component - -> ComponentLocalBuildInfo - -> FilePath - -> IO () -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CLib lib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg_descr lbi lib' clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CFLib flib) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - replFLib replFlags verbosity pkg_descr lbi flib clbi - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CExe exe) clbi _ = do - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} }) - clbi _distPref = do - let exe = testSuiteExeV10AsExe test - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent replFlags verbosity pkg_descr lbi0 suffixes - comp@(CTest - test@TestSuite { testInterface = TestSuiteLibV09{} }) - clbi distPref = do - pwd <- getCurrentDirectory - let (pkg, lib, libClbi, lbi, _, _, _) = - testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let libbi = libBuildInfo lib - lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } } - replLib replFlags verbosity pkg lbi lib' libClbi - - -replComponent _ verbosity _ _ _ - (CTest TestSuite { testInterface = TestSuiteUnsupported tt }) - _ _ = - die' verbosity $ "No support for building test suite type " ++ prettyShow tt - - -replComponent replFlags verbosity pkg_descr lbi suffixes - comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} }) - clbi _distPref = do - let exe = benchmarkExeV10asExe bm - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - extras <- preprocessExtras verbosity comp lbi - let ebi = buildInfo exe - exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } } - replExe replFlags verbosity pkg_descr lbi exe' clbi - - -replComponent _ verbosity _ _ _ - (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt }) - _ _ = - die' verbosity $ "No support for building benchmark type " ++ prettyShow tt - ----------------------------------------------------- --- Shared code for buildComponent and replComponent --- - --- | Translate a exe-style 'TestSuite' component into an exe for building -testSuiteExeV10AsExe :: TestSuite -> Executable -testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = - Executable { - exeName = testName test, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } -testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" - --- | Translate a exe-style 'Benchmark' component into an exe for building -benchmarkExeV10asExe :: Benchmark -> Executable -benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = - Executable { - exeName = benchmarkName bm, - modulePath = mainFile, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bm - } -benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" - --- | Translate a lib-style 'TestSuite' component into a lib + exe for building -testSuiteLibV09AsLibAndExe :: PackageDescription - -> TestSuite - -> ComponentLocalBuildInfo - -> LocalBuildInfo - -> FilePath - -> FilePath - -> (PackageDescription, - Library, ComponentLocalBuildInfo, - LocalBuildInfo, - IPI.InstalledPackageInfo, - Executable, ComponentLocalBuildInfo) -testSuiteLibV09AsLibAndExe pkg_descr - test@TestSuite { testInterface = TestSuiteLibV09 _ m } - clbi lbi distPref pwd = - (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) - where - bi = testBuildInfo test - lib = Library { - libName = LMainLibName, - exposedModules = [ m ], - reexportedModules = [], - signatures = [], - libExposed = True, - libVisibility = LibraryVisibilityPrivate, - libBuildInfo = bi - } - -- This is, like, the one place where we use a CTestName for a library. - -- Should NOT use library name, since that could conflict! - PackageIdentifier pkg_name pkg_ver = package pkg_descr - -- Note: we do make internal library from the test! - compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) - compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) - libClbi = LibComponentLocalBuildInfo - { componentPackageDeps = componentPackageDeps clbi - , componentInternalDeps = componentInternalDeps clbi - , componentIsIndefinite_ = False - , componentExeDeps = componentExeDeps clbi - , componentLocalName = CLibName $ LSubLibName $ testName test - , componentIsPublic = False - , componentIncludes = componentIncludes clbi - , componentUnitId = componentUnitId clbi - , componentComponentId = componentComponentId clbi - , componentInstantiatedWith = [] - , componentCompatPackageName = compat_name - , componentCompatPackageKey = compat_key - , componentExposedModules = [IPI.ExposedModule m Nothing] - } - pkgName' = mkPackageName $ prettyShow compat_name - pkg = pkg_descr { - package = (package pkg_descr) { pkgName = pkgName' } - , executables = [] - , testSuites = [] - , subLibraries = [lib] - } - ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi - testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - testLibDep = Dependency - pkgName' - (thisVersion $ pkgVersion $ package pkg_descr) - mainLibSet - exe = Executable { - exeName = mkUnqualComponentName $ stubName test, - modulePath = stubFilePath test, - exeScope = ExecutablePublic, - buildInfo = (testBuildInfo test) { - hsSourceDirs = [ unsafeMakeSymbolicPath testDir ], - targetBuildDepends = testLibDep - : (targetBuildDepends $ testBuildInfo test) - } - } - -- | The stub executable needs a new 'ComponentLocalBuildInfo' - -- that exposes the relevant test suite library. - deps = (IPI.installedUnitId ipi, mungedId ipi) - : (filter (\(_, x) -> let name = prettyShow $ mungedName x - in name == "Cabal" || name == "base") - (componentPackageDeps clbi)) - exeClbi = ExeComponentLocalBuildInfo { - -- TODO: this is a hack, but as long as this is unique - -- (doesn't clobber something) we won't run into trouble - componentUnitId = mkUnitId (stubName test), - componentComponentId = mkComponentId (stubName test), - componentInternalDeps = [componentUnitId clbi], - componentExeDeps = [], - componentLocalName = CExeName $ mkUnqualComponentName $ stubName test, - componentPackageDeps = deps, - -- Assert DefUnitId invariant! - -- Executable can't be indefinite, so dependencies must - -- be definite packages. - componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps) - (repeat defaultRenaming) - } -testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" - - --- | Initialize a new package db file for libraries defined --- internally to the package. -createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath - -> IO PackageDB -createInternalPackageDB verbosity lbi distPref = do - existsAlready <- doesPackageDBExist dbPath - when existsAlready $ deletePackageDB dbPath - createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath - return (SpecificPackageDB dbPath) - where - dbPath = internalPackageDBPath lbi distPref - -addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo - -> ProgramDb -> ProgramDb -addInternalBuildTools pkg lbi bi progs = - foldr updateProgram progs internalBuildTools - where - internalBuildTools = - [ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation) - | toolName <- getAllInternalToolDependencies pkg bi - , let toolName' = unUnqualComponentName toolName - , let toolLocation = buildDir lbi toolName' toolName' <.> exeExtension (hostPlatform lbi) ] - - --- TODO: build separate libs in separate dirs so that we can build --- multiple libs, e.g. for 'LibTest' library-style test suites -buildLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity numJobs pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi - GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi - UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi - HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi - _ -> die' verbosity "Building is not supported with this compiler." - --- | Build a foreign library --- --- NOTE: We assume that we already checked that we can actually build the --- foreign library in configure. -buildFLib :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib verbosity numJobs pkg_descr lbi flib clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi - _ -> die' verbosity "Building is not supported with this compiler." - -buildExe :: Verbosity -> Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity numJobs pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi - GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi - UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi - _ -> die' verbosity "Building is not supported with this compiler." - -replLib :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -replLib replFlags verbosity pkg_descr lbi lib clbi = - case compilerFlavor (compiler lbi) of - -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass - -- NoFlag as the numJobs parameter. - GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - GHCJS -> GHCJS.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replExe :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo - -> IO () -replExe replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - GHCJS -> GHCJS.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - -replFLib :: [String] -> Verbosity -> PackageDescription - -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo - -> IO () -replFLib replFlags verbosity pkg_descr lbi exe clbi = - case compilerFlavor (compiler lbi) of - GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi - _ -> die' verbosity "A REPL is not supported for this compiler." - --- | Runs 'componentInitialBuildSteps' on every configured component. -initialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> Verbosity -- ^The verbosity to use - -> IO () -initialBuildSteps distPref pkg_descr lbi verbosity = - withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi -> - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - --- | Creates the autogenerated files for a particular configured component. -componentInitialBuildSteps :: FilePath -- ^"dist" prefix - -> PackageDescription -- ^mostly information from the .cabal file - -> LocalBuildInfo -- ^Configuration information - -> ComponentLocalBuildInfo - -> Verbosity -- ^The verbosity to use - -> IO () -componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do - createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi) - - writeAutogenFiles verbosity pkg_descr lbi clbi - --- | Generate and write out the Paths_.hs and cabal_macros.h files --- -writeAutogenFiles :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> IO () -writeAutogenFiles verbosity pkg lbi clbi = do - createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi) - - let pathsModulePath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs" - pathsModuleDir = takeDirectory pathsModulePath - -- Ensure that the directory exists! - createDirectoryIfMissingVerbose verbosity True pathsModuleDir - rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi) - - --TODO: document what we're doing here, and move it to its own function - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - -- Write out empty hsig files for all requirements, so that GHC - -- has a source file to look at it when it needs to typecheck - -- a signature. It's harmless to write these out even when - -- there is a real hsig file written by the user, since - -- include path ordering ensures that the real hsig file - -- will always be picked up before the autogenerated one. - for_ (map fst insts) $ \mod_name -> do - let sigPath = autogenComponentModulesDir lbi clbi - ModuleName.toFilePath mod_name <.> "hsig" - createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath) - rewriteFileEx verbosity sigPath $ - "{-# OPTIONS_GHC -w #-}\n" ++ - "{-# LANGUAGE NoImplicitPrelude #-}\n" ++ - "signature " ++ prettyShow mod_name ++ " where" - _ -> return () - - let cppHeaderPath = autogenComponentModulesDir lbi clbi cppHeaderName - rewriteFileEx verbosity cppHeaderPath (generateCabalMacrosHeader pkg lbi clbi) +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008, 2012 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +module Distribution.Simple.Build + ( -- * Build + build + , build_setupHooks + + -- * Repl + , repl + , repl_setupHooks + , startInterpreter + + -- * Build preparation + , preBuildComponent + , AutogenFile (..) + , AutogenFileContents + , writeBuiltinAutogenFiles + , writeAutogenFiles + + -- ** Legacy functions + , componentInitialBuildSteps + , initialBuildSteps + + -- * Internal package database creation + , createInternalPackageDB + + -- * Handling of internal build tools + , addInternalBuildTools + ) where + +import Distribution.Compat.Prelude +import Distribution.Utils.Generic +import Prelude () + +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.Dependency +import Distribution.Types.ExecutableScope +import Distribution.Types.ForeignLib +import Distribution.Types.LibraryVisibility +import Distribution.Types.LocalBuildInfo +import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.Path + +import Distribution.Backpack +import Distribution.Backpack.DescribeUnitId +import Distribution.Package +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC + +import Distribution.Simple.Build.Macros (generateCabalMacrosHeader) +import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule) +import Distribution.Simple.Build.PathsModule (generatePathsModule, pkgPathEnvVar) +import qualified Distribution.Simple.Program.HcPkg as HcPkg + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Simple.Compiler + +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.Configure +import Distribution.Simple.Flag +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Db +import qualified Distribution.Simple.Program.GHC as GHC +import Distribution.Simple.Program.Types +import Distribution.Simple.Register +import Distribution.Simple.Setup.Build +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Repl +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , BuildingWhat (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks +import Distribution.Simple.ShowBuildInfo +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.Utils.Json +import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText) + +import Distribution.Pretty +import Distribution.System +import Distribution.Verbosity +import Distribution.Version (thisVersion) + +import Distribution.Compat.Graph (IsNode (..)) + +import Control.Monad +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as Map +import Distribution.Simple.Errors +import System.Directory (doesFileExist, removeFile) +import System.FilePath (takeDirectory) + +-- ----------------------------------------------------------------------------- + +-- | Build the libraries and executables in this package. +build + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build = build_setupHooks noBuildHooks + +build_setupHooks + :: BuildHooks + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> IO () +build_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild}) + pkg_descr + lbi + flags + suffixHandlers = do + checkSemaphoreSupport verbosity (compiler lbi) flags + targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags) + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) + info verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + when (null targets) $ + -- Only bother with this message if we're building the whole package + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + -- Before the actual building, dump out build-information. + -- This way, if the actual compilation failed, the options have still been + -- dumped. + dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags + + curDir <- absoluteWorkingDirLBI lbi + + -- Now do the actual building + (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do + let comp = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo comp + -- Include any build-tool-depends on build tools internal to the current package. + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildNormal flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi' target + let numJobs = buildNumJobs flags + par_strat <- + toFlag <$> case buildUseSemaphore flags of + Flag sem_name -> case numJobs of + Flag{} -> do + warn verbosity $ "Ignoring -j due to --semaphore" + return $ UseSem sem_name + NoFlag -> return $ UseSem sem_name + NoFlag -> return $ case numJobs of + Flag n -> NumJobs n + NoFlag -> Serial + mb_ipi <- + buildComponent + flags + par_strat + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + let postBuildInputs = + SetupHooks.PostBuildComponentInputs + { SetupHooks.buildFlags = flags + , SetupHooks.localBuildInfo = lbi' + , SetupHooks.targetInfo = target + } + for_ mbPostBuild ($ postBuildInputs) + return (maybe index (Index.insert `flip` index) mb_ipi) + + return () + where + distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + +-- | Check for conditions that would prevent the build from succeeding. +checkSemaphoreSupport + :: Verbosity -> Compiler -> BuildFlags -> IO () +checkSemaphoreSupport verbosity comp flags = do + unless (jsemSupported comp || (isNothing (flagToMaybe (buildUseSemaphore flags)))) $ + dieWithException verbosity CheckSemaphoreSupport + +-- | Write available build information for 'LocalBuildInfo' to disk. +-- +-- Dumps detailed build information 'build-info.json' to the given directory. +-- Build information contains basics such as compiler details, but also +-- lists what modules a component contains and how to compile the component, assuming +-- lib:Cabal made sure that dependencies are up-to-date. +dumpBuildInfo + :: Verbosity + -> SymbolicPath Pkg (Dir Dist) + -- ^ To which directory should the build-info be dumped? + -> Flag DumpBuildInfo + -- ^ Should we dump detailed build information for this component? + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> IO () +dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do + when shouldDumpBuildInfo $ do + -- Changing this line might break consumers of the dumped build info. + -- Announce changes on mailing lists! + let activeTargets = allTargetsInBuildOrder' pkg_descr lbi + info verbosity $ + "Dump build information for: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + activeTargets + ) + + (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of + Nothing -> + dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi)) + Just program -> requireProgram verbosity program (withPrograms lbi) + + wdir <- absoluteWorkingDirLBI lbi + let (warns, json) = mkBuildInfo wdir pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets + buildInfoText = renderJson json + unless (null warns) $ + warn verbosity $ + "Encountered warnings while dumping build-info:\n" + ++ unlines warns + LBS.writeFile buildInfoFile buildInfoText + + when (not shouldDumpBuildInfo) $ do + -- Remove existing build-info.json as it might be outdated now. + exists <- doesFileExist buildInfoFile + when exists $ removeFile buildInfoFile + where + buildInfoFile = interpretSymbolicPathLBI lbi $ buildInfoPref distPref + shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo + + -- \| Given the flavor of the compiler, try to find out + -- which program we need. + flavorToProgram :: CompilerFlavor -> Maybe Program + flavorToProgram GHC = Just ghcProgram + flavorToProgram GHCJS = Just ghcjsProgram + flavorToProgram UHC = Just uhcProgram + flavorToProgram JHC = Just jhcProgram + flavorToProgram _ = Nothing + +repl + :: PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl = repl_setupHooks noBuildHooks + +repl_setupHooks + :: BuildHooks + -- ^ build hook + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> ReplFlags + -- ^ Flags that the user passed to build + -> [PPSuffixHandler] + -- ^ preprocessors to run before compiling + -> [String] + -> IO () +repl_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + flags + suffixHandlers + args = do + let distPref = fromFlag (replDistPref flags) + verbosity = fromFlag (replVerbosity flags) + + target <- + readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of + -- This seems DEEPLY questionable. + [] -> case allTargetsInBuildOrder' pkg_descr lbi of + (target : _) -> return target + [] -> dieWithException verbosity $ FailedToDetermineTarget + [target] -> return target + _ -> dieWithException verbosity $ NoMultipleTargets + let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target] + debug verbosity $ + "Component build order: " + ++ intercalate + ", " + ( map + (showComponentName . componentLocalName . targetCLBI) + componentsToBuild + ) + + internalPackageDB <- createInternalPackageDB verbosity lbi distPref + + let lbiForComponent comp lbi' = do + curDir <- absoluteWorkingDirLBI lbi' + return $ + lbi' + { withPackageDB = withPackageDB lbi' ++ [internalPackageDB] + , withPrograms = + -- Include any build-tool-depends on build tools internal to the current package. + addInternalBuildTools + curDir + pkg_descr + lbi' + (componentBuildInfo comp) + (withPrograms lbi') + } + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildRepl flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- build any dependent components + sequence_ + [ do + let clbi = targetCLBI subtarget + comp = targetComponent subtarget + lbi' <- lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' subtarget + buildComponent + (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}}) + NoFlag + pkg_descr + lbi' + suffixHandlers + comp + clbi + distPref + | subtarget <- safeInit componentsToBuild + ] + + -- REPL for target components + let clbi = targetCLBI target + comp = targetComponent target + lbi' <- lbiForComponent comp lbi + preBuildComponent runPreBuildHooks verbosity lbi' target + replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref + +-- | Start an interpreter without loading any package files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity programDb comp platform packageDBs = + case compilerFlavor comp of + GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs + GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs + _ -> dieWithException verbosity REPLNotSupported + +buildComponent + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO (Maybe InstalledPackageInfo) +buildComponent flags _ _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ + NoSupportBuildingTestSuite tt +buildComponent flags _ _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException (fromFlag $ buildVerbosity flags) $ + NoSupportBuildingBenchMark tt +buildComponent + flags + numJobs + pkg_descr + lbi0 + suffixHandlers + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi -- This ComponentLocalBuildInfo corresponds to a detailed + -- test suite and not a real component. It should not + -- be used, except to construct the CLBIs for the + -- library and stub executable that will actually be + -- built. + distPref = + do + inplaceDir <- absoluteWorkingDirLBI lbi0 + let verbosity = fromFlag $ buildVerbosity flags + let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir} + buildLib flags numJobs pkg lbi lib' libClbi + -- NB: need to enable multiple instances here, because on 7.10+ + -- the package name is the same as the library, and we still + -- want the registration to go through. + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (mbWorkDirLBI lbi) + (withPackageDB lbi) + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + let ebi = buildInfo exe + -- NB: The stub executable is linked against the test-library + -- which already contains all `other-modules`, so we need + -- to remove those from the stub-exe's build-info + exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}} + buildExe verbosity numJobs pkg_descr lbi exe' exeClbi + return Nothing -- Can't depend on test suite +buildComponent + flags + numJobs + pkg_descr + lbi + suffixHandlers + comp + clbi + distPref = + do + let verbosity = fromFlag $ buildVerbosity flags + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + setupMessage' + verbosity + "Building" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + case comp of + CLib lib -> do + let libbi = libBuildInfo lib + lib' = + lib + { libBuildInfo = + flip addExtraAsmSources extras $ + flip addExtraCmmSources extras $ + flip addExtraCxxSources extras $ + flip addExtraCSources extras $ + flip addExtraJsSources extras $ + libbi + } + + buildLib flags numJobs pkg_descr lbi lib' clbi + + let oneComponentRequested (OneComponentRequestedSpec _) = True + oneComponentRequested _ = False + -- Don't register inplace if we're only building a single component; + -- it's not necessary because there won't be any subsequent builds + -- that need to tag us + if (not (oneComponentRequested (componentEnabledSpec lbi))) + then do + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + inplaceDir <- absoluteWorkingDirLBI lbi + let + -- The in place registration uses the "-inplace" suffix, not an ABI hash + installedPkgInfo = + inplaceInstalledPackageInfo + inplaceDir + distPref + pkg_descr + -- NB: Use a fake ABI hash to avoid + -- needing to recompute it every build. + (mkAbiHash "inplace") + lib' + lbi + clbi + debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (flagToMaybe $ buildWorkingDir flags) + (withPackageDB lbi) + installedPkgInfo + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + return (Just installedPkgInfo) + else return Nothing + CFLib flib -> do + buildFLib verbosity numJobs pkg_descr lbi flib clbi + return Nothing + CExe exe -> do + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do + let exe = testSuiteExeV10AsExe test + (genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity + let ebi = buildInfo exe + exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing + CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do + let exe = benchmarkExeV10asExe bm + let ebi = buildInfo exe + exe' = exe{buildInfo = addExtraCSources ebi extras} + buildExe verbosity numJobs pkg_descr lbi exe' clbi + return Nothing +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +generateCode + :: [String] + -> UnqualComponentName + -> PackageDescription + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Verbosity + -> IO (SymbolicPath Pkg (Dir Source), [ModuleName.ModuleName]) +generateCode codeGens nm pdesc bi lbi clbi verbosity = do + when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True $ i tgtDir + (\x -> (tgtDir, x)) . concat <$> mapM go codeGens + where + allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc) + dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi + srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs + nm' = unUnqualComponentName nm + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + tgtDir = buildDir lbi makeRelativePathEx (nm' nm' ++ "-gen") + go :: String -> IO [ModuleName.ModuleName] + go codeGenProg = + fmap fromString . lines + <$> getDbProgramOutputCwd + verbosity + mbWorkDir + (simpleProgram codeGenProg) + (withPrograms lbi) + ( map interpretSymbolicPathCWD (tgtDir : srcDirs) + ++ ( "--" + : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir) + ) + ) + +-- | Add extra C sources generated by preprocessing to build +-- information. +addExtraCSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCSources bi extras = bi{cSources = new} + where + new = ordNub (extras ++ cSources bi) + +-- | Add extra C++ sources generated by preprocessing to build +-- information. +addExtraCxxSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCxxSources bi extras = bi{cxxSources = new} + where + new = ordNub (extras ++ cxxSources bi) + +-- | Add extra C-- sources generated by preprocessing to build +-- information. +addExtraCmmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraCmmSources bi extras = bi{cmmSources = new} + where + new = ordNub (extras ++ cmmSources bi) + +-- | Add extra ASM sources generated by preprocessing to build +-- information. +addExtraAsmSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraAsmSources bi extras = bi{asmSources = new} + where + new = ordNub (extras ++ asmSources bi) + +-- | Add extra JS sources generated by preprocessing to build +-- information. +addExtraJsSources :: BuildInfo -> [SymbolicPath Pkg File] -> BuildInfo +addExtraJsSources bi extras = bi{jsSources = new} + where + new = ordNub (extras ++ jsSources bi) + +-- | Add extra HS modules generated by preprocessing to build +-- information. +addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo +addExtraOtherModules bi extras = bi{otherModules = new} + where + new = ordNub (extras ++ otherModules bi) + +-- | Add extra source dir for generated modules. +addSrcDir :: BuildInfo -> SymbolicPath Pkg (Dir Source) -> BuildInfo +addSrcDir bi extra = bi{hsSourceDirs = new} + where + new = ordNub (extra : hsSourceDirs bi) + +replComponent + :: ReplFlags + -> Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> Component + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO () +replComponent _ verbosity _ _ _ (CTest TestSuite{testInterface = TestSuiteUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingTestSuite tt +replComponent _ verbosity _ _ _ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt}) _ _ = + dieWithException verbosity $ NoSupportBuildingBenchMark tt +replComponent + replFlags + verbosity + pkg_descr + lbi0 + suffixHandlers + comp@( CTest + test@TestSuite{testInterface = TestSuiteLibV09{}} + ) + clbi + distPref = do + inplaceDir <- absoluteWorkingDirLBI lbi0 + let (pkg, lib, libClbi, lbi, _, _, _) = + testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 inplaceDir distPref + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + replLib replFlags pkg lbi lib' libClbi +replComponent + replFlags + verbosity + pkg_descr + lbi + suffixHandlers + comp + clbi + _ = + do + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixHandlers + extras <- preprocessExtras verbosity comp lbi + case comp of + CLib lib -> do + let libbi = libBuildInfo lib + lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}} + replLib replFlags pkg_descr lbi lib' clbi + CFLib flib -> + replFLib replFlags pkg_descr lbi flib clbi + CExe exe -> do + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi + CTest test@TestSuite{testInterface = TestSuiteExeV10{}} -> do + let exe = testSuiteExeV10AsExe test + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi + CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}} -> do + let exe = benchmarkExeV10asExe bm + let ebi = buildInfo exe + exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}} + replExe replFlags pkg_descr lbi exe' clbi +#if __GLASGOW_HASKELL__ < 811 +-- silence pattern-match warnings prior to GHC 9.0 + _ -> error "impossible" +#endif + +---------------------------------------------------- +-- Shared code for buildComponent and replComponent +-- + +-- | Translate a exe-style 'TestSuite' component into an exe for building +testSuiteExeV10AsExe :: TestSuite -> Executable +testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} = + Executable + { exeName = testName test + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } +testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind" + +-- | Translate a exe-style 'Benchmark' component into an exe for building +benchmarkExeV10asExe :: Benchmark -> Executable +benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} = + Executable + { exeName = benchmarkName bm + , modulePath = mainFile + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bm + } +benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind" + +-- | Translate a lib-style 'TestSuite' component into a lib + exe for building +testSuiteLibV09AsLibAndExe + :: PackageDescription + -> TestSuite + -> ComponentLocalBuildInfo + -> LocalBuildInfo + -> AbsolutePath (Dir Pkg) + -- ^ absolute inplace dir + -> SymbolicPath Pkg (Dir Dist) + -> ( PackageDescription + , Library + , ComponentLocalBuildInfo + , LocalBuildInfo + , IPI.InstalledPackageInfo + , Executable + , ComponentLocalBuildInfo + ) +testSuiteLibV09AsLibAndExe + pkg_descr + test@TestSuite{testInterface = TestSuiteLibV09 _ m} + clbi + lbi + inplaceDir + distPref = + (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) + where + bi = testBuildInfo test + lib = + Library + { libName = LMainLibName + , exposedModules = [m] + , reexportedModules = [] + , signatures = [] + , libExposed = True + , libVisibility = LibraryVisibilityPrivate + , libBuildInfo = bi + } + -- This is, like, the one place where we use a CTestName for a library. + -- Should NOT use library name, since that could conflict! + PackageIdentifier pkg_name pkg_ver = package pkg_descr + -- Note: we do make internal library from the test! + compat_name = MungedPackageName pkg_name (LSubLibName (testName test)) + compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi) + libClbi = + LibComponentLocalBuildInfo + { componentPackageDeps = componentPackageDeps clbi + , componentInternalDeps = componentInternalDeps clbi + , componentIsIndefinite_ = False + , componentExeDeps = componentExeDeps clbi + , componentLocalName = CLibName $ LSubLibName $ testName test + , componentIsPublic = False + , componentIncludes = componentIncludes clbi + , componentUnitId = componentUnitId clbi + , componentComponentId = componentComponentId clbi + , componentInstantiatedWith = [] + , componentCompatPackageName = compat_name + , componentCompatPackageKey = compat_key + , componentExposedModules = [IPI.ExposedModule m Nothing] + } + pkgName' = mkPackageName $ prettyShow compat_name + pkg = + pkg_descr + { package = (package pkg_descr){pkgName = pkgName'} + , executables = [] + , testSuites = [] + , subLibraries = [lib] + } + ipi = inplaceInstalledPackageInfo inplaceDir distPref pkg (mkAbiHash "") lib lbi libClbi + testLibDep = + Dependency + pkgName' + (thisVersion $ pkgVersion $ package pkg_descr) + mainLibSet + exe = + Executable + { exeName = mkUnqualComponentName $ stubName test + , modulePath = makeRelativePathEx $ stubFilePath test + , exeScope = ExecutablePublic + , buildInfo = + (testBuildInfo test) + { hsSourceDirs = [coerceSymbolicPath $ testBuildDir lbi test] + , targetBuildDepends = + testLibDep + : targetBuildDepends (testBuildInfo test) + } + } + -- \| The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + deps = + (IPI.installedUnitId ipi, mungedId ipi) + : ( filter + ( \(_, x) -> + let name = prettyShow $ mungedName x + in name == "Cabal" || name == "base" + ) + (componentPackageDeps clbi) + ) + exeClbi = + ExeComponentLocalBuildInfo + { -- TODO: this is a hack, but as long as this is unique + -- (doesn't clobber something) we won't run into trouble + componentUnitId = mkUnitId (stubName test) + , componentComponentId = mkComponentId (stubName test) + , componentInternalDeps = [componentUnitId clbi] + , componentExeDeps = [] + , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test + , componentPackageDeps = deps + , -- Assert DefUnitId invariant! + -- Executable can't be indefinite, so dependencies must + -- be definite packages. + componentIncludes = + map ((,defaultRenaming) . DefiniteUnitId . unsafeMkDefUnitId . fst) deps + } +testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB + :: Verbosity + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> IO PackageDB +createInternalPackageDB verbosity lbi distPref = do + existsAlready <- doesPackageDBExist dbPath + when existsAlready $ deletePackageDB dbPath + createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath + return (SpecificPackageDB dbRelPath) + where + dbRelPath = internalPackageDBPath lbi distPref + dbPath = interpretSymbolicPathLBI lbi dbRelPath + +-- | Update the program database to include any build-tool-depends specified +-- in the given 'BuildInfo' on build tools internal to the current package. +-- +-- This function: +-- +-- - adds these internal build tools to the 'ProgramDb', including +-- paths to their respective data directories, +-- - adds their paths to the current 'progSearchPath', and adds the data +-- directory environment variable for the current package to the current +-- 'progOverrideEnv', so that any programs configured from now on will be +-- able to invoke these build tools. +addInternalBuildTools + :: AbsolutePath (Dir Pkg) + -> PackageDescription + -> LocalBuildInfo + -> BuildInfo + -> ProgramDb + -> ProgramDb +addInternalBuildTools pwd pkg lbi bi progs = + prependProgramSearchPathNoLogging + internalToolPaths + [pkgDataDirVar] + $ foldr updateProgram progs internalBuildTools + where + internalToolPaths = map (takeDirectory . programPath) internalBuildTools + pkgDataDirVar = (pkgPathEnvVar pkg "datadir", Just dataDirPath) + internalBuildTools = + [ (simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)) + { programOverrideEnv = [pkgDataDirVar] + } + | toolName <- getAllInternalToolDependencies pkg bi + , let toolName' = unUnqualComponentName toolName + , let toolLocation = + interpretSymbolicPathLBI lbi $ + buildDir lbi + makeRelativePathEx (toolName' toolName' <.> exeExtension (hostPlatform lbi)) + ] + + -- This is an absolute path, so if a process changes directory, it can still + -- find the datadir (#10717) + dataDirPath :: FilePath + dataDirPath = interpretSymbolicPathAbsolute pwd (dataDir pkg) + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style test suites +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg_descr lbi lib clbi = + let verbosity = fromFlag $ buildVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib flags numJobs pkg_descr lbi lib clbi + GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +-- | Build a foreign library +-- +-- NOTE: We assume that we already checked that we can actually build the +-- foreign library in configure. +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib verbosity numJobs pkg_descr lbi flib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe verbosity numJobs pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi + GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> dieWithException verbosity BuildingNotSupportedWithCompiler + +replLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib replFlags pkg_descr lbi lib clbi = + let verbosity = fromFlag $ replVerbosity replFlags + opts = replReplOptions replFlags + in case compilerFlavor (compiler lbi) of + -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass + -- NoFlag as the numJobs parameter. + GHC -> GHC.replLib replFlags NoFlag pkg_descr lbi lib clbi + GHCJS -> GHCJS.replLib (replOptionsFlags opts) verbosity NoFlag pkg_descr lbi lib clbi + _ -> dieWithException verbosity REPLNotSupported + +replExe + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replExe flags NoFlag pkg_descr lbi exe clbi + GHCJS -> + GHCJS.replExe + (replOptionsFlags $ replReplOptions flags) + verbosity + NoFlag + pkg_descr + lbi + exe + clbi + _ -> dieWithException verbosity REPLNotSupported + +replFLib + :: ReplFlags + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib flags pkg_descr lbi exe clbi = + let verbosity = fromFlag $ replVerbosity flags + in case compilerFlavor (compiler lbi) of + GHC -> GHC.replFLib flags NoFlag pkg_descr lbi exe clbi + _ -> dieWithException verbosity REPLNotSupported + +-- | Runs 'componentInitialBuildSteps' on every configured component. +-- +-- Legacy function: does not run pre-build hooks or pre-processors. This function +-- is insufficient on its own to prepare the build for a package. +-- +-- Consumers wanting to prepare the sources of a package, e.g. in order to +-- launch a REPL session, are advised to run @Setup repl --repl-multi-file=@ +-- 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='." + #-} + +-- | 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 --repl-multi-file=@ 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 --repl-multi-file='." + #-} + +-- | 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_.hs@, +-- - @PackageInfo_.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_.hs@, +-- - @PackageInfo_.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 diff --git a/src/Distribution/Simple/Build/Inputs.hs b/src/Distribution/Simple/Build/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/Inputs.hs @@ -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 diff --git a/src/Distribution/Simple/Build/Macros.hs b/src/Distribution/Simple/Build/Macros.hs --- a/src/Distribution/Simple/Build/Macros.hs +++ b/src/Distribution/Simple/Build/Macros.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Simon Marlow 2008 @@ -18,93 +19,96 @@ -- numbers. -- -- TODO Figure out what to do about backpack and internal libraries. It is very --- suspecious that this stuff works with munged package identifiers -module Distribution.Simple.Build.Macros ( - generateCabalMacrosHeader, - generatePackageVersionMacros, +-- suspicious that this stuff works with munged package identifiers +module Distribution.Simple.Build.Macros + ( generateCabalMacrosHeader + , generatePackageVersionMacros ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Version import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Db import Distribution.Simple.Program.Types import Distribution.Types.MungedPackageId import Distribution.Types.MungedPackageName -import Distribution.Pretty +import Distribution.Version import qualified Distribution.Simple.Build.Macros.Z as Z -- | The contents of the @cabal_macros.h@ for the given configured package. --- generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) - , Z.zTools = - [ Z.ZTool - { Z.ztoolName = programId prog +generateCabalMacrosHeader pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi) + , Z.zTools = + [ Z.ZTool + { Z.ztoolName = programId prog , Z.ztoolVersion = ver - , Z.ztoolX = major1 - , Z.ztoolY = major2 - , Z.ztoolZ = minor + , Z.ztoolX = major1 + , Z.ztoolY = major2 + , Z.ztoolZ = minor } - | prog <- configuredPrograms $ withPrograms lbi - , ver <- maybeToList (programVersion prog) - , let (major1,major2,minor) = majorMinor ver - ] - , Z.zPackageKey = case clbi of - LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi - _ -> "" - , Z.zComponentId = prettyShow (componentComponentId clbi) - , Z.zPackageVersion = pkgVersion (package pkg_descr) - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } + | prog <- configuredPrograms $ withPrograms lbi + , ver <- maybeToList (programVersion prog) + , let (major1, major2, minor) = majorMinor ver + ] + , Z.zPackageKey = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = compatPackageKey} -> compatPackageKey + _ -> "" + , Z.zComponentId = prettyShow (componentComponentId clbi) + , Z.zPackageVersion = pkgVersion (package pkg_descr) + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } where getPid (_, MungedPackageId (MungedPackageName pn _) v) = - -- NB: Drop the library name! We're just reporting package versions. - -- This would have to be revisited if you are allowed to depend - -- on different versions of the same package - PackageIdentifier pn v + -- NB: Drop the library name! We're just reporting package versions. + -- This would have to be revisited if you are allowed to depend + -- on different versions of the same package + PackageIdentifier pn v -- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@ -- macros for a list of package ids (usually used with the specific deps of -- a configured package). --- generatePackageVersionMacros :: Version -> [PackageId] -> String -generatePackageVersionMacros ver pkgids = Z.render Z.Z - { Z.zPackages = map mkZPackage pkgids - , Z.zTools = [] - , Z.zPackageKey = "" - , Z.zComponentId = "" - , Z.zPackageVersion = ver - , Z.zNotNull = not . null - , Z.zManglePkgName = map fixchar . unPackageName - , Z.zMangleStr = map fixchar - } +generatePackageVersionMacros ver pkgids = + Z.render + Z.Z + { Z.zPackages = map mkZPackage pkgids + , Z.zTools = [] + , Z.zPackageKey = "" + , Z.zComponentId = "" + , Z.zPackageVersion = ver + , Z.zNotNull = not . null + , Z.zManglePkgName = map fixchar . unPackageName + , Z.zMangleStr = map fixchar + } mkZPackage :: PackageId -> Z.ZPackage -mkZPackage (PackageIdentifier name ver) = Z.ZPackage - { Z.zpkgName = name +mkZPackage (PackageIdentifier name ver) = + Z.ZPackage + { Z.zpkgName = name , Z.zpkgVersion = ver - , Z.zpkgX = major1 - , Z.zpkgY = major2 - , Z.zpkgZ = minor + , Z.zpkgX = major1 + , Z.zpkgY = major2 + , Z.zpkgZ = minor } where - (major1,major2,minor) = majorMinor ver + (major1, major2, minor) = majorMinor ver majorMinor :: Version -> (String, String, String) majorMinor ver = case map show (versionNumbers ver) of - [] -> ("0", "0", "0") - [x] -> (x, "0", "0") - [x,y] -> (x, y, "0") - (x:y:z:_) -> (x, y, z) + [] -> ("0", "0", "0") + [x] -> (x, "0", "0") + [x, y] -> (x, y, "0") + (x : y : z : _) -> (x, y, z) fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/src/Distribution/Simple/Build/Macros/Z.hs b/src/Distribution/Simple/Build/Macros/Z.hs --- a/src/Distribution/Simple/Build/Macros/Z.hs +++ b/src/Distribution/Simple/Build/Macros/Z.hs @@ -1,9 +1,10 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.Macros.Z (render, Z(..), ZPackage (..), ZTool (..)) where import Distribution.ZinzaPrelude data Z - = Z {zPackages :: ([ZPackage]), - zTools :: ([ZTool]), + = Z {zPackages :: [ZPackage], + zTools :: [ZTool], zPackageKey :: String, zComponentId :: String, zPackageVersion :: Version, diff --git a/src/Distribution/Simple/Build/PackageInfoModule.hs b/src/Distribution/Simple/Build/PackageInfoModule.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/PackageInfoModule.hs @@ -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_.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 diff --git a/src/Distribution/Simple/Build/PackageInfoModule/Z.hs b/src/Distribution/Simple/Build/PackageInfoModule/Z.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Build/PackageInfoModule/Z.hs @@ -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" diff --git a/src/Distribution/Simple/Build/PathsModule.hs b/src/Distribution/Simple/Build/PathsModule.hs --- a/src/Distribution/Simple/Build/PathsModule.hs +++ b/src/Distribution/Simple/Build/PathsModule.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Build.Macros -- Copyright : Isaac Jones 2003-2005, @@ -13,9 +14,9 @@ -- This is a module that Cabal generates for the benefit of packages. It -- enables them to find their version number and find any installed data files -- at runtime. This code should probably be split off into another module. --- -module Distribution.Simple.Build.PathsModule ( - generatePathsModule, pkgPathEnvVar +module Distribution.Simple.Build.PathsModule + ( generatePathsModule + , pkgPathEnvVar ) where import Distribution.Compat.Prelude @@ -25,121 +26,125 @@ import Distribution.PackageDescription import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Utils (shortRelativePath) +import Distribution.Simple.Utils (shortRelativePath) import Distribution.System import Distribution.Version import qualified Distribution.Simple.Build.PathsModule.Z as Z -- ------------------------------------------------------------ + -- * Building Paths_.hs + -- ------------------------------------------------------------ generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String -generatePathsModule pkg_descr lbi clbi = Z.render Z.Z - { Z.zPackageName = packageName pkg_descr - , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr - , Z.zSupportsCpp = supports_cpp - , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax - , Z.zAbsolute = absolute - , Z.zRelocatable = relocatable lbi - , Z.zIsWindows = isWindows - , Z.zIsI386 = buildArch == I386 - , Z.zIsX8664 = buildArch == X86_64 - , Z.zNot = not - , Z.zManglePkgName = showPkgName - - , Z.zPrefix = show flat_prefix - , Z.zBindir = zBindir - , Z.zLibdir = zLibdir - , Z.zDynlibdir = zDynlibdir - , Z.zDatadir = zDatadir - , Z.zLibexecdir = zLibexecdir - , Z.zSysconfdir = zSysconfdir - } +generatePathsModule pkg_descr lbi clbi = + Z.render + Z.Z + { Z.zPackageName = packageName pkg_descr + , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr + , Z.zSupportsCpp = supports_cpp + , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax + , Z.zAbsolute = absolute + , Z.zRelocatable = relocatable lbi + , Z.zIsWindows = isWindows + , Z.zIsI386 = buildArch == I386 + , Z.zIsX8664 = buildArch == X86_64 + , Z.zIsAArch64 = buildArch == AArch64 + , Z.zNot = not + , Z.zManglePkgName = showPkgName + , Z.zPrefix = show flat_prefix + , Z.zBindir = zBindir + , Z.zLibdir = zLibdir + , Z.zDynlibdir = zDynlibdir + , Z.zDatadir = zDatadir + , Z.zLibexecdir = zLibexecdir + , Z.zSysconfdir = zSysconfdir + } where - supports_cpp = supports_language_pragma - supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1]) - supports_language_pragma = ghc_newer_than (mkVersion [6,6,1]) + supports_cpp = supports_language_pragma + supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1]) + supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1]) ghc_newer_than minVersion = - case compilerCompatVersion GHC (compiler lbi) of - Nothing -> False - Just version -> version `withinRange` orLaterVersion minVersion + case compilerCompatVersion GHC (compiler lbi) of + Nothing -> False + Just version -> version `withinRange` orLaterVersion minVersion -- In several cases we cannot make relocatable installations absolute = - hasLibs pkg_descr -- we can only make progs relocatable - || isNothing flat_bindirrel -- if the bin dir is an absolute path - || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) -- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform isWindows = case buildOS of - Windows -> True - _ -> False + Windows -> True + _ -> False - supportsRelocatableProgs GHC = isWindows + supportsRelocatableProgs GHC = isWindows supportsRelocatableProgs GHCJS = isWindows - supportsRelocatableProgs _ = False + supportsRelocatableProgs _ = False cid = componentUnitId clbi InstallDirs - { bindir = flat_bindir - , libdir = flat_libdir - , dynlibdir = flat_dynlibdir - , datadir = flat_datadir - , libexecdir = flat_libexecdir - , sysconfdir = flat_sysconfdir - , prefix = flat_prefix - } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest + { bindir = flat_bindir + , libdir = flat_libdir + , dynlibdir = flat_dynlibdir + , datadir = flat_datadir + , libexecdir = flat_libexecdir + , sysconfdir = flat_sysconfdir + , prefix = flat_prefix + } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest InstallDirs - { bindir = flat_bindirrel - , libdir = flat_libdirrel - , dynlibdir = flat_dynlibdirrel - , datadir = flat_datadirrel - , libexecdir = flat_libexecdirrel - , sysconfdir = flat_sysconfdirrel - } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid + { bindir = flat_bindirrel + , libdir = flat_libdirrel + , dynlibdir = flat_dynlibdirrel + , datadir = flat_datadirrel + , libexecdir = flat_libexecdirrel + , sysconfdir = flat_sysconfdirrel + } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String (zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir) - | relocatable lbi = - ( show flat_bindir_reloc - , show flat_libdir_reloc - , show flat_dynlibdir_reloc - , show flat_datadir_reloc - , show flat_libexecdir_reloc - , show flat_sysconfdir_reloc - ) - | absolute = - ( show flat_bindir - , show flat_libdir - , show flat_dynlibdir - , show flat_datadir - , show flat_libexecdir - , show flat_sysconfdir - ) - | isWindows = - ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" - , mkGetDir flat_libdir flat_libdirrel - , mkGetDir flat_dynlibdir flat_dynlibdirrel - , mkGetDir flat_datadir flat_datadirrel - , mkGetDir flat_libexecdir flat_libexecdirrel - , mkGetDir flat_sysconfdir flat_sysconfdirrel - ) - | otherwise = - error "panic! generatePathsModule: should never happen" + | relocatable lbi = + ( show flat_bindir_reloc + , show flat_libdir_reloc + , show flat_dynlibdir_reloc + , show flat_datadir_reloc + , show flat_libexecdir_reloc + , show flat_sysconfdir_reloc + ) + | absolute = + ( show flat_bindir + , show flat_libdir + , show flat_dynlibdir + , show flat_datadir + , show flat_libexecdir + , show flat_sysconfdir + ) + | isWindows = + ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")" + , mkGetDir flat_libdir flat_libdirrel + , mkGetDir flat_dynlibdir flat_dynlibdirrel + , mkGetDir flat_datadir flat_datadirrel + , mkGetDir flat_libexecdir flat_libexecdirrel + , mkGetDir flat_sysconfdir flat_sysconfdirrel + ) + | otherwise = + error "panic! generatePathsModule: should never happen" mkGetDir :: FilePath -> Maybe FilePath -> String - mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel - mkGetDir dir Nothing = "return " ++ show dir + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir - flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir - flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir - flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir - flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir + flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir + flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir + flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir + flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir @@ -149,15 +154,17 @@ -- Note: The format of these strings is part of Cabal's public API; -- changing this function constitutes a *backwards-compatibility* break. pkgPathEnvVar - :: PackageDescription - -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" - -> String -- ^ environment variable name + :: PackageDescription + -> String + -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\" + -> String + -- ^ environment variable name pkgPathEnvVar pkg_descr var = - showPkgName (packageName pkg_descr) ++ "_" ++ var + showPkgName (packageName pkg_descr) ++ "_" ++ var showPkgName :: PackageName -> String showPkgName = map fixchar . unPackageName fixchar :: Char -> Char fixchar '-' = '_' -fixchar c = c +fixchar c = c diff --git a/src/Distribution/Simple/Build/PathsModule/Z.hs b/src/Distribution/Simple/Build/PathsModule/Z.hs --- a/src/Distribution/Simple/Build/PathsModule/Z.hs +++ b/src/Distribution/Simple/Build/PathsModule/Z.hs @@ -1,3 +1,4 @@ +{- FOURMOLU_DISABLE -} {-# LANGUAGE DeriveGeneric #-} module Distribution.Simple.Build.PathsModule.Z (render, Z(..)) where import Distribution.ZinzaPrelude @@ -11,6 +12,7 @@ zIsWindows :: Bool, zIsI386 :: Bool, zIsX8664 :: Bool, + zIsAArch64 :: Bool, zPrefix :: FilePath, zBindir :: FilePath, zLibdir :: FilePath, @@ -41,8 +43,35 @@ return () else do return () - tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n" + if (zSupportsCpp z_root) + then do + tell "#if __GLASGOW_HASKELL__ >= 810\n" + tell "{-# OPTIONS_GHC -Wno-prepositive-qualified-module #-}\n" + tell "#endif\n" + return () + else do + return () + tell "{-# OPTIONS_GHC -Wno-missing-import-lists #-}\n" tell "{-# OPTIONS_GHC -w #-}\n" + tell "\n" + tell "{-|\n" + tell "Module : Paths_" + tell (zManglePkgName z_root (zPackageName z_root)) + tell "\n" + tell "Description : Data file location, and package version and installation\n" + tell " directories.\n" + tell "\n" + tell "WARNING: This module was generated by Cabal. Any modifications will be\n" + tell "overwritten if the module is regenerated.\n" + tell "\n" + tell "This module exports a function to locate data files, and values that record\n" + tell "the version of the package and some directories which the package has been\n" + tell "configured to be installed into.\n" + tell "\n" + tell "For further information about Cabal's options for its configuration step, and\n" + tell "their default values, see the Cabal User Guide.\n" + tell "-}\n" + tell "\n" tell "module Paths_" tell (zManglePkgName z_root (zPackageName z_root)) tell " (\n" @@ -60,7 +89,6 @@ return () tell "\n" tell "import qualified Control.Exception as Exception\n" - tell "import qualified Data.List as List\n" tell "import Data.Version (Version(..))\n" tell "import System.Environment (getEnv)\n" tell "import Prelude\n" @@ -92,19 +120,88 @@ tell "catchIO = Exception.catch\n" return () tell "\n" + tell "-- |The package version.\n" tell "version :: Version\n" tell "version = Version " tell (zVersionDigits z_root) tell " []\n" tell "\n" + tell "-- |If the argument is a filename, the result is the name of a corresponding\n" + tell "-- file on the system on which the program is running, if the file were listed\n" + tell "-- in the @data-files@ field of the package's Cabal package description file.\n" + tell "-- No check is performed that the given filename is listed in that field.\n" tell "getDataFileName :: FilePath -> IO FilePath\n" tell "getDataFileName name = do\n" tell " dir <- getDataDir\n" tell " return (dir `joinFileName` name)\n" tell "\n" - tell "getBinDir, getLibDir, getDynLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n" + tell "-- |The location of the directory specified by Cabal's @--bindir@ option (where\n" + tell "-- executables that the user might invoke are installed). This can be overridden\n" + tell "-- at runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_bindir.\n" + tell "getBinDir :: IO FilePath\n" tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libdir@ option (where\n" + tell "-- object libraries are installed). This can be overridden at runtime using the\n" + tell "-- environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libdir.\n" + tell "getLibDir :: IO FilePath\n" tell "\n" + tell "-- |The location of the directory specified by Cabal's @--dynlibdir@ option\n" + tell "-- (where dynamic libraries are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_dynlibdir.\n" + tell "getDynLibDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--datadir@ option (where\n" + tell "-- architecture-independent data files are installed). This can be overridden at\n" + tell "-- runtime using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_datadir.\n" + tell "getDataDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--libexedir@ option\n" + tell "-- (where executables that are not expected to be invoked directly by the user\n" + tell "-- are installed). This can be overridden at runtime using the environment\n" + tell "-- variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_libexedir.\n" + tell "getLibexecDir :: IO FilePath\n" + tell "\n" + tell "-- |The location of the directory specified by Cabal's @--sysconfdir@ option\n" + tell "-- (where configuration files are installed). This can be overridden at runtime\n" + tell "-- using the environment variable " + tell (zManglePkgName z_root (zPackageName z_root)) + tell "_sysconfdir.\n" + tell "getSysconfDir :: IO FilePath\n" + tell "\n" + let + z_var0_function_defs = do + tell "minusFileName :: FilePath -> String -> FilePath\n" + tell "minusFileName dir \"\" = dir\n" + tell "minusFileName dir \".\" = dir\n" + tell "minusFileName dir suffix =\n" + tell " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n" + tell "\n" + tell "splitFileName :: FilePath -> (String, String)\n" + tell "splitFileName p = (reverse (path2++drive), reverse fname)\n" + tell " where\n" + tell " (path,drive) = case p of\n" + tell " (c:':':p') -> (reverse p',[':',c])\n" + tell " _ -> (reverse p ,\"\")\n" + tell " (fname,path1) = break isPathSeparator path\n" + tell " path2 = case path1 of\n" + tell " [] -> \".\"\n" + tell " [_] -> path1 -- don't remove the trailing slash if\n" + tell " -- there is only one character\n" + tell " (c:path') | isPathSeparator c -> path'\n" + tell " _ -> path1\n" + return () + tell "\n" + tell "\n" if (zRelocatable z_root) then do tell "\n" @@ -147,6 +244,8 @@ tell (zSysconfdir z_root) tell ")\n" tell "\n" + z_var0_function_defs + tell "\n" return () else do if (zAbsolute z_root) @@ -237,6 +336,8 @@ tell ") `joinFileName` dirRel)\n" tell " | otherwise -> try_size (size * 2)\n" tell "\n" + z_var0_function_defs + tell "\n" if (zIsI386 z_root) then do tell "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n" @@ -249,9 +350,16 @@ tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" return () else do - tell "-- win32 supported only with I386, X86_64\n" - tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" - tell "c_GetModuleFileName = _\n" + if (zIsAArch64 z_root) + then do + tell "foreign import ccall unsafe \"windows.h GetModuleFileNameW\"\n" + tell " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + return () + else do + tell "-- win32 supported only with I386, X86_64, AArch64\n" + tell "c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + tell "c_GetModuleFileName = _\n" + return () return () return () tell "\n" @@ -266,38 +374,18 @@ return () tell "\n" tell "\n" - if (zNot z_root (zAbsolute z_root)) - then do - tell "minusFileName :: FilePath -> String -> FilePath\n" - tell "minusFileName dir \"\" = dir\n" - tell "minusFileName dir \".\" = dir\n" - tell "minusFileName dir suffix =\n" - tell " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n" - tell "\n" - tell "splitFileName :: FilePath -> (String, String)\n" - tell "splitFileName p = (reverse (path2++drive), reverse fname)\n" - tell " where\n" - tell " (path,drive) = case p of\n" - tell " (c:':':p') -> (reverse p',[':',c])\n" - tell " _ -> (reverse p ,\"\")\n" - tell " (fname,path1) = break isPathSeparator path\n" - tell " path2 = case path1 of\n" - tell " [] -> \".\"\n" - tell " [_] -> path1 -- don't remove the trailing slash if\n" - tell " -- there is only one character\n" - tell " (c:path') | isPathSeparator c -> path'\n" - tell " _ -> path1\n" - return () - else do - return () - tell "\n" tell "joinFileName :: String -> String -> FilePath\n" tell "joinFileName \"\" fname = fname\n" tell "joinFileName \".\" fname = fname\n" tell "joinFileName dir \"\" = dir\n" - tell "joinFileName dir fname\n" - tell " | isPathSeparator (List.last dir) = dir ++ fname\n" + tell "joinFileName dir@(c:cs) fname\n" + tell " | isPathSeparator (lastChar c cs) = dir ++ fname\n" tell " | otherwise = dir ++ pathSeparator : fname\n" + tell " where\n" + tell " -- We do not use Data.List.NonEmpty.last, as that would limit the module to\n" + tell " -- base >= 4.9.0.0 (GHC >= 8.0.1).\n" + tell " lastChar x [] = x\n" + tell " lastChar _ (x:xs) = lastChar x xs\n" tell "\n" tell "pathSeparator :: Char\n" if (zIsWindows z_root) diff --git a/src/Distribution/Simple/BuildPaths.hs b/src/Distribution/Simple/BuildPaths.hs --- a/src/Distribution/Simple/BuildPaths.hs +++ b/src/Distribution/Simple/BuildPaths.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.BuildPaths -- Copyright : Isaac Jones 2003-2004, @@ -11,52 +14,71 @@ -- Portability : portable -- -- A bunch of dirs, paths and file names used for intermediate build steps. --- - -module Distribution.Simple.BuildPaths ( - defaultDistPref, srcPref, - haddockDirName, hscolourPref, haddockPref, - autogenPackageModulesDir, - autogenComponentModulesDir, - - autogenPathsModuleName, - cppHeaderName, - haddockName, - - mkGenericStaticLibName, - mkLibName, - mkProfLibName, - mkGenericSharedLibName, - mkSharedLibName, - mkStaticLibName, - mkGenericSharedBundledLibName, +module Distribution.Simple.BuildPaths + ( defaultDistPref + , srcPref + , buildInfoPref + , haddockDirName + , haddockLibraryDirPath + , haddockTestDirPath + , haddockBenchmarkDirPath + , hscolourPref + , haddockPref + , autogenPackageModulesDir + , autogenComponentModulesDir + , autogenPathsModuleName + , autogenPackageInfoModuleName + , cppHeaderName + , haddockPath + , haddockPackageLibraryName + , haddockPackageLibraryName' + , haddockLibraryName + , haddockLibraryPath + , mkGenericStaticLibName + , mkLibName + , mkProfLibName + , mkGenericSharedLibName + , mkSharedLibName + , mkProfSharedLibName + , mkStaticLibName + , mkGenericSharedBundledLibName + , exeExtension + , objExtension + , dllExtension + , staticLibExtension - exeExtension, - objExtension, - dllExtension, - staticLibExtension, -- * Source files & build directories - getSourceFiles, getLibSourceFiles, getExeSourceFiles, - getFLibSourceFiles, exeBuildDir, flibBuildDir, + , getSourceFiles + , getLibSourceFiles + , getExeSourceFiles + , getTestSourceFiles + , getBenchmarkSourceFiles + , getFLibSourceFiles + , exeBuildDir + , flibBuildDir + , stubName + , testBuildDir + , benchmarkBuildDir ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Package -import Distribution.ModuleName as ModuleName +import Data.List (stripPrefix) import Distribution.Compiler +import Distribution.ModuleName as ModuleName +import Distribution.Package import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Setup import Distribution.Pretty -import Distribution.System -import Distribution.Verbosity +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess.Types (builtinHaskellSuffixes) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Haddock (HaddockTarget (..)) import Distribution.Simple.Utils +import Distribution.System import Distribution.Utils.Path - -import Data.List (stripPrefix) -import System.FilePath ((), (<.>), normalise) +import Distribution.Verbosity -- --------------------------------------------------------------------------- -- Build directories and files @@ -64,29 +86,78 @@ srcPref :: FilePath -> FilePath srcPref distPref = distPref "src" -hscolourPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath +hscolourPref + :: HaddockTarget + -> SymbolicPath root (Dir Dist) + -> PackageDescription + -> SymbolicPath root (Dir Artifacts) hscolourPref = haddockPref +-- | Build info json file, generated in every build +buildInfoPref + :: SymbolicPath root (Dir Dist) + -> SymbolicPath root File +buildInfoPref distPref = distPref makeRelativePathEx "build-info.json" + -- | This is the name of the directory in which the generated haddocks -- should be stored. It does not include the @/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 @/doc/html@ +-- prefix. +-- +-- It is also used by `haddock-project` when constructing its output directory. +haddockLibraryDirPath + :: HaddockTarget + -> PackageDescription + -> Library + -> FilePath +haddockLibraryDirPath haddockTarget pkg_descr lib = + case libName lib of + LSubLibName sublib_name -> + haddockDirName haddockTarget pkg_descr prettyShow sublib_name + _ -> haddockDirName haddockTarget pkg_descr + +haddockTestDirPath + :: HaddockTarget + -> PackageDescription + -> TestSuite + -> FilePath +haddockTestDirPath haddockTarget pkg_descr test = + haddockDirName haddockTarget pkg_descr prettyShow (testName test) + +haddockBenchmarkDirPath + :: HaddockTarget + -> PackageDescription + -> Benchmark + -> FilePath +haddockBenchmarkDirPath haddockTarget pkg_descr bench = + haddockDirName haddockTarget pkg_descr prettyShow (benchmarkName bench) + -- | The directory to which generated haddock documentation should be written. -haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath -haddockPref haddockTarget distPref pkg_descr - = distPref "doc" "html" haddockDirName haddockTarget pkg_descr +haddockPref + :: HaddockTarget + -> SymbolicPath root (Dir Dist) + -> PackageDescription + -> SymbolicPath root (Dir Artifacts) +haddockPref haddockTarget distPref pkg_descr = + distPref makeRelativePathEx ("doc" "html" haddockDirName haddockTarget pkg_descr) -- | The directory in which we put auto-generated modules for EVERY -- component in the package. -autogenPackageModulesDir :: LocalBuildInfo -> String -autogenPackageModulesDir lbi = buildDir lbi "global-autogen" +autogenPackageModulesDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Source) +autogenPackageModulesDir lbi = buildDir lbi makeRelativePathEx "global-autogen" -- | The directory in which we put auto-generated modules for a -- particular component. -autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String -autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi "autogen" +autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source) +autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi makeRelativePathEx "autogen" + -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. @@ -98,78 +169,203 @@ autogenPathsModuleName pkg_descr = ModuleName.fromString $ "Paths_" ++ map fixchar (prettyShow (packageName pkg_descr)) - where fixchar '-' = '_' - fixchar c = c + where + fixchar '-' = '_' + fixchar c = c -haddockName :: PackageDescription -> FilePath -haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" +-- | The name of the auto-generated PackageInfo_* module associated with a package +autogenPackageInfoModuleName :: PackageDescription -> ModuleName +autogenPackageInfoModuleName pkg_descr = + ModuleName.fromString $ + "PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr)) + where + fixchar '-' = '_' + fixchar c = c +haddockPath :: PackageDescription -> FilePath +haddockPath pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock" + +-- | A name of a (sub)library used by haddock, in the form +-- `:` if it is a sublibrary, or `` if it is the +-- main library. +-- +-- Used by `haddock-project` and `Distribution.Simple.Haddock`. +haddockPackageLibraryName :: PackageDescription -> Library -> String +haddockPackageLibraryName pkg_descr lib = + haddockPackageLibraryName' (packageName pkg_descr) (libName lib) + +haddockPackageLibraryName' :: PackageName -> LibraryName -> String +haddockPackageLibraryName' pkg_name lib_name = + case lib_name of + LSubLibName sublib_name -> + prettyShow pkg_name ++ ":" ++ prettyShow sublib_name + LMainLibName -> prettyShow pkg_name + +-- | A name of a (sub)library used by haddock. +haddockLibraryName :: PackageDescription -> Library -> String +haddockLibraryName pkg_descr lib = + case libName lib of + LSubLibName sublib_name -> prettyShow sublib_name + LMainLibName -> prettyShow (packageName pkg_descr) + +-- | File path of the ".haddock" file. +haddockLibraryPath :: PackageDescription -> Library -> FilePath +haddockLibraryPath pkg_descr lib = haddockLibraryName pkg_descr lib <.> "haddock" + -- ----------------------------------------------------------------------------- -- Source File helper -getLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules +getLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)] +getLibSourceFiles verbosity lbi lib clbi = + getSourceFiles verbosity mbWorkDir searchpaths modules where - bi = libBuildInfo lib - modules = allLibModules lib clbi - searchpaths = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] + bi = libBuildInfo lib + modules = allLibModules lib clbi + mbWorkDir = mbWorkDirLBI lbi + searchpaths = + coerceSymbolicPath (componentBuildDir lbi clbi) + : hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] -getExeSourceFiles :: Verbosity - -> LocalBuildInfo - -> Executable - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] getExeSourceFiles verbosity lbi exe clbi = do - moduleFiles <- getSourceFiles verbosity searchpaths modules - srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe) - return ((ModuleName.main, srcMainPath) : moduleFiles) + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) where - bi = buildInfo exe - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi) + mbWorkDir = mbWorkDirLBI lbi + bi = buildInfo exe + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (exeBuildDir lbi exe) + : hsSourceDirs bi -getFLibSourceFiles :: Verbosity - -> LocalBuildInfo - -> ForeignLib - -> ComponentLocalBuildInfo - -> IO [(ModuleName.ModuleName, FilePath)] -getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules +getTestSourceFiles + :: Verbosity + -> LocalBuildInfo + -> TestSuite + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] +getTestSourceFiles verbosity lbi test@TestSuite{testInterface = TestSuiteExeV10 _ path} clbi = do + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path + return ((ModuleName.main, srcMainPath) : moduleFiles) where - bi = foreignLibBuildInfo flib - modules = otherModules bi - searchpaths = autogenComponentModulesDir lbi clbi - : autogenPackageModulesDir lbi - : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi) + mbWorkDir = mbWorkDirLBI lbi + bi = testBuildInfo test + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (testBuildDir lbi test) + : hsSourceDirs bi +getTestSourceFiles _ _ _ _ = return [] -getSourceFiles :: Verbosity -> [FilePath] - -> [ModuleName.ModuleName] - -> IO [(ModuleName.ModuleName, FilePath)] -getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $ - findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m) - >>= maybe (notFound m) (return . normalise) +getBenchmarkSourceFiles + :: Verbosity + -> LocalBuildInfo + -> Benchmark + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg 'File)] +getBenchmarkSourceFiles verbosity lbi bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ path} clbi = do + moduleFiles <- getSourceFiles verbosity mbWorkDir searchpaths modules + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs bi) path + return ((ModuleName.main, srcMainPath) : moduleFiles) where - notFound module_ = die' verbosity $ "can't find source for module " ++ prettyShow module_ + mbWorkDir = mbWorkDirLBI lbi + bi = benchmarkBuildInfo bench + modules = otherModules bi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (benchmarkBuildDir lbi bench) + : hsSourceDirs bi +getBenchmarkSourceFiles _ _ _ _ = return [] +getFLibSourceFiles + :: Verbosity + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO [(ModuleName.ModuleName, SymbolicPath Pkg File)] +getFLibSourceFiles verbosity lbi flib clbi = + getSourceFiles verbosity mbWorkDir searchpaths modules + where + bi = foreignLibBuildInfo flib + modules = otherModules bi + mbWorkDir = mbWorkDirLBI lbi + searchpaths = + autogenComponentModulesDir lbi clbi + : autogenPackageModulesDir lbi + : coerceSymbolicPath (flibBuildDir lbi flib) + : hsSourceDirs bi + +getSourceFiles + :: Verbosity + -> Maybe (SymbolicPath CWD ('Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir Source)] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, SymbolicPathX allowAbsolute Pkg File)] +getSourceFiles verbosity mbWorkDir dirs modules = flip traverse modules $ \m -> + fmap ((,) m) $ + findFileCwdWithExtension + mbWorkDir + builtinHaskellSuffixes + dirs + (moduleNameSymbolicPath m) + >>= maybe (notFound m) (return . normaliseSymbolicPath) + where + notFound module_ = + dieWithException verbosity $ CantFindSourceModule module_ + -- | The directory where we put build results for an executable -exeBuildDir :: LocalBuildInfo -> Executable -> FilePath -exeBuildDir lbi exe = buildDir lbi nm nm ++ "-tmp" +exeBuildDir :: LocalBuildInfo -> Executable -> SymbolicPath Pkg (Dir Build) +exeBuildDir lbi exe = buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") where nm = unUnqualComponentName $ exeName exe -- | The directory where we put build results for a foreign library -flibBuildDir :: LocalBuildInfo -> ForeignLib -> FilePath -flibBuildDir lbi flib = buildDir lbi nm nm ++ "-tmp" +flibBuildDir :: LocalBuildInfo -> ForeignLib -> SymbolicPath Pkg (Dir Build) +flibBuildDir lbi flib = buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") where nm = unUnqualComponentName $ foreignLibName flib +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: TestSuite -> FilePath +stubName t = unUnqualComponentName (testName t) ++ "Stub" + +-- | The directory where we put build results for a test suite +testBuildDir :: LocalBuildInfo -> TestSuite -> SymbolicPath Pkg (Dir Build) +testBuildDir lbi tst = + buildDir lbi makeRelativePathEx testDir + where + testDir = case testInterface tst of + TestSuiteLibV09{} -> + stubName tst stubName tst ++ "-tmp" + _ -> nm nm ++ "-tmp" + nm = unUnqualComponentName $ testName tst + +-- | The directory where we put build results for a benchmark suite +benchmarkBuildDir :: LocalBuildInfo -> Benchmark -> SymbolicPath Pkg (Dir Build) +benchmarkBuildDir lbi bm = + buildDir lbi makeRelativePathEx (nm nm ++ "-tmp") + where + nm = unUnqualComponentName $ benchmarkName bm + -- --------------------------------------------------------------------------- -- Library file names @@ -182,29 +378,35 @@ mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib) mkProfLibName :: UnitId -> String -mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") +mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p") -- | Create a library name for a shared library from a given name. -- Prepends @lib@ and appends the @-\\@ -- as well as the shared library extension. mkGenericSharedLibName :: Platform -> CompilerId -> String -> String -mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib - = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ] - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib = + mconcat ["lib", lib, "-", comp <.> dllExtension platform] + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- Implement proper name mangling for dynamical shared objects -- @libHS\-\\@ -- e.g. @libHSbase-2.1-ghc6.6.1.so@ mkSharedLibName :: Platform -> CompilerId -> UnitId -> String -mkSharedLibName platform comp lib - = mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib) +mkProfSharedLibName :: Platform -> CompilerId -> UnitId -> String +mkProfSharedLibName platform comp lib = + mkGenericSharedLibName platform comp (getHSLibraryName lib ++ "_p") + -- Static libs are named the same as shared libraries, only with -- a different extension. mkStaticLibName :: Platform -> CompilerId -> UnitId -> String -mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib - = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform - where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion +mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib = + "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform + where + comp = prettyShow compilerFlavor ++ prettyShow compilerVersion -- | Create a library name for a bundled shared library from a given name. -- This matches the naming convention for shared libraries as implemented in @@ -217,23 +419,26 @@ -- "Cffi" -> "libffi.so" mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String mkGenericSharedBundledLibName platform comp lib - | "HS" `isPrefixOf` lib - = mkGenericSharedLibName platform comp lib - | Just lib' <- stripPrefix "C" lib - = "lib" ++ lib' <.> dllExtension platform - | otherwise - = error ("Don't understand library name " ++ lib) + | "HS" `isPrefixOf` lib = + mkGenericSharedLibName platform comp lib + | Just lib' <- stripPrefix "C" lib = + "lib" ++ lib' <.> dllExtension platform + | otherwise = + error ("Don't understand library name " ++ lib) -- ------------------------------------------------------------ + -- * Platform file extensions + -- ------------------------------------------------------------ -- | Default extension for executable files on the current platform. -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) exeExtension :: Platform -> String -exeExtension (Platform _arch os) = case os of - Windows -> "exe" - _ -> "" +exeExtension platform = case platform of + Platform _ Windows -> "exe" + Platform Wasm32 _ -> "wasm" + _ -> "" -- | Extension for object files. For GHC the extension is @\"o\"@. objExtension :: String @@ -242,10 +447,10 @@ -- | Extension for dynamically linked (or shared) libraries -- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) dllExtension :: Platform -> String -dllExtension (Platform _arch os)= case os of - Windows -> "dll" - OSX -> "dylib" - _ -> "so" +dllExtension (Platform _arch os) = case os of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" -- | Extension for static libraries -- @@ -253,5 +458,5 @@ -- interested in, not the build OS. staticLibExtension :: Platform -> String staticLibExtension (Platform _arch os) = case os of - Windows -> "lib" - _ -> "a" + Windows -> "lib" + _ -> "a" diff --git a/src/Distribution/Simple/BuildTarget.hs b/src/Distribution/Simple/BuildTarget.hs --- a/src/Distribution/Simple/BuildTarget.hs +++ b/src/Distribution/Simple/BuildTarget.hs @@ -1,1064 +1,1110 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildTargets --- Copyright : (c) Duncan Coutts 2012 --- License : BSD-like --- --- Maintainer : duncan@community.haskell.org --- --- Handling for user-specified build targets ------------------------------------------------------------------------------ -module Distribution.Simple.BuildTarget ( - -- * Main interface - readTargetInfos, - readBuildTargets, -- in case you don't have LocalBuildInfo - - -- * Build targets - BuildTarget(..), - showBuildTarget, - QualLevel(..), - buildTargetComponentName, - - -- * Parsing user build targets - UserBuildTarget, - readUserBuildTargets, - showUserBuildTarget, - UserBuildTargetProblem(..), - reportUserBuildTargetProblems, - - -- * Resolving build targets - resolveBuildTargets, - BuildTargetProblem(..), - reportBuildTargetProblems, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName - -import Distribution.Package -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.LocalBuildInfo -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Simple.Utils -import Distribution.Verbosity -import Distribution.Utils.Path - -import qualified Distribution.Compat.CharParsing as P - -import Control.Monad ( msum ) -import Data.List ( stripPrefix, groupBy ) -import qualified Data.List.NonEmpty as NE -import System.FilePath as FilePath - ( dropExtension, normalise, splitDirectories, joinPath, splitPath - , hasTrailingPathSeparator ) -import System.Directory ( doesFileExist, doesDirectoryExist ) -import qualified Data.Map as Map - --- | Take a list of 'String' build targets, and parse and validate them --- into actual 'TargetInfo's to be built/registered/whatever. -readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] -readTargetInfos verbosity pkg_descr lbi args = do - build_targets <- readBuildTargets verbosity pkg_descr args - checkBuildTargets verbosity pkg_descr lbi build_targets - --- ------------------------------------------------------------ --- * User build targets --- ------------------------------------------------------------ - --- | Various ways that a user may specify a build target. --- -data UserBuildTarget = - - -- | A target specified by a single name. This could be a component - -- module or file. - -- - -- > cabal build foo - -- > cabal build Data.Foo - -- > cabal build Data/Foo.hs Data/Foo.hsc - -- - UserBuildTargetSingle String - - -- | A target specified by a qualifier and name. This could be a component - -- name qualified by the component namespace kind, or a module or file - -- qualified by the component name. - -- - -- > cabal build lib:foo exe:foo - -- > cabal build foo:Data.Foo - -- > cabal build foo:Data/Foo.hs - -- - | UserBuildTargetDouble String String - - -- | A fully qualified target, either a module or file qualified by a - -- component name with the component namespace kind. - -- - -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs - -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo - -- - | UserBuildTargetTriple String String String - deriving (Show, Eq, Ord) - - --- ------------------------------------------------------------ --- * Resolved build targets --- ------------------------------------------------------------ - --- | A fully resolved build target. --- -data BuildTarget = - - -- | A specific component - -- - BuildTargetComponent ComponentName - - -- | A specific module within a specific component. - -- - | BuildTargetModule ComponentName ModuleName - - -- | A specific file within a specific component. - -- - | BuildTargetFile ComponentName FilePath - deriving (Eq, Show, Generic) - -instance Binary BuildTarget - -buildTargetComponentName :: BuildTarget -> ComponentName -buildTargetComponentName (BuildTargetComponent cn) = cn -buildTargetComponentName (BuildTargetModule cn _) = cn -buildTargetComponentName (BuildTargetFile cn _) = cn - --- | Read a list of user-supplied build target strings and resolve them to --- 'BuildTarget's according to a 'PackageDescription'. If there are problems --- with any of the targets e.g. they don't exist or are misformatted, throw an --- 'IOException'. -readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] -readBuildTargets verbosity pkg targetStrs = do - let (uproblems, utargets) = readUserBuildTargets targetStrs - reportUserBuildTargetProblems verbosity uproblems - - utargets' <- traverse checkTargetExistsAsFile utargets - - let (bproblems, btargets) = resolveBuildTargets pkg utargets' - reportBuildTargetProblems verbosity bproblems - - return btargets - -checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) -checkTargetExistsAsFile t = do - fexists <- existsAsFile (fileComponentOfTarget t) - return (t, fexists) - - where - existsAsFile f = do - exists <- doesFileExist f - case splitPath f of - (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d - (d:_:_) | not exists -> doesDirectoryExist d - _ -> return exists - - fileComponentOfTarget (UserBuildTargetSingle s1) = s1 - fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 - fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 - - --- ------------------------------------------------------------ --- * Parsing user targets --- ------------------------------------------------------------ - -readUserBuildTargets :: [String] -> ([UserBuildTargetProblem] - ,[UserBuildTarget]) -readUserBuildTargets = partitionEithers . map readUserBuildTarget - --- | --- --- >>> readUserBuildTarget "comp" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:comp" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "\"comp\"" --- Right (UserBuildTargetSingle "comp") --- --- >>> readUserBuildTarget "lib:\"comp\"" --- Right (UserBuildTargetDouble "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:\"comp\"" --- Right (UserBuildTargetTriple "pkg" "lib" "comp") --- --- >>> readUserBuildTarget "pkg:lib:comp:more" --- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") --- --- >>> readUserBuildTarget "pkg:\"lib\":comp" --- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") --- -readUserBuildTarget :: String -> Either UserBuildTargetProblem - UserBuildTarget -readUserBuildTarget targetstr = - case explicitEitherParsec parseTargetApprox targetstr of - Left _ -> Left (UserBuildTargetUnrecognised targetstr) - Right tgt -> Right tgt - - where - parseTargetApprox :: CabalParsing m => m UserBuildTarget - parseTargetApprox = do - -- read one, two, or three tokens, where last could be "hs-string" - ts <- tokens - return $ case ts of - (a, Nothing) -> UserBuildTargetSingle a - (a, Just (b, Nothing)) -> UserBuildTargetDouble a b - (a, Just (b, Just c)) -> UserBuildTargetTriple a b c - - tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) - tokens = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) - - tokens2 :: CabalParsing m => m (String, Maybe String) - tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString - <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) - - token :: CabalParsing m => m String - token = P.munch1 (\x -> not (isSpace x) && x /= ':') - -data UserBuildTargetProblem - = UserBuildTargetUnrecognised String - deriving Show - -reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () -reportUserBuildTargetProblems verbosity problems = do - case [ target | UserBuildTargetUnrecognised target <- problems ] of - [] -> return () - target -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ name ++ "'." - | name <- target ] - ++ "Examples:\n" - ++ " - build foo -- component name " - ++ "(library, executable, test-suite or benchmark)\n" - ++ " - build Data.Foo -- module name\n" - ++ " - build Data/Foo.hsc -- file name\n" - ++ " - build lib:foo exe:foo -- component qualified by kind\n" - ++ " - build foo:Data.Foo -- module qualified by component\n" - ++ " - build foo:Data/Foo.hsc -- file qualified by component" - -showUserBuildTarget :: UserBuildTarget -> String -showUserBuildTarget = intercalate ":" . getComponents - where - getComponents (UserBuildTargetSingle s1) = [s1] - getComponents (UserBuildTargetDouble s1 s2) = [s1,s2] - getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3] - --- | Unless you use 'QL1', this function is PARTIAL; --- use 'showBuildTarget' instead. -showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String -showBuildTarget' ql pkgid bt = - showUserBuildTarget (renderBuildTarget ql bt pkgid) - --- | Unambiguously render a 'BuildTarget', so that it can --- be parsed in all situations. -showBuildTarget :: PackageId -> BuildTarget -> String -showBuildTarget pkgid t = - showBuildTarget' (qlBuildTarget t) pkgid t - where - qlBuildTarget BuildTargetComponent{} = QL2 - qlBuildTarget _ = QL3 - - --- ------------------------------------------------------------ --- * Resolving user targets to build targets --- ------------------------------------------------------------ - -{- -stargets = - [ BuildTargetComponent (CExeName "foo") - , BuildTargetModule (CExeName "foo") (mkMn "Foo") - , BuildTargetModule (CExeName "tst") (mkMn "Foo") - ] - where - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - -ex_pkgid :: PackageIdentifier -Just ex_pkgid = simpleParse "thelib" --} - --- | Given a bunch of user-specified targets, try to resolve what it is they --- refer to. --- -resolveBuildTargets :: PackageDescription - -> [(UserBuildTarget, Bool)] - -> ([BuildTargetProblem], [BuildTarget]) -resolveBuildTargets pkg = partitionEithers - . map (uncurry (resolveBuildTarget pkg)) - -resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool - -> Either BuildTargetProblem BuildTarget -resolveBuildTarget pkg userTarget fexists = - case findMatch (matchBuildTarget pkg userTarget fexists) of - Unambiguous target -> Right target - Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') - where targets' = disambiguateBuildTargets - (packageId pkg) - userTarget - targets - None errs -> Left (classifyMatchErrors errs) - - where - classifyMatchErrors errs - | Just expected' <- NE.nonEmpty expected - = let (things, got:|_) = NE.unzip expected' in - BuildTargetExpected userTarget (NE.toList things) got - | not (null nosuch) = BuildTargetNoSuch userTarget nosuch - | otherwise = error $ "resolveBuildTarget: internal error in matching" - where - expected = [ (thing, got) | MatchErrorExpected thing got <- errs ] - nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ] - - -data BuildTargetProblem - = BuildTargetExpected UserBuildTarget [String] String - -- ^ [expected thing] (actually got) - | BuildTargetNoSuch UserBuildTarget [(String, String)] - -- ^ [(no such thing, actually got)] - | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] - deriving Show - - -disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget] - -> [(UserBuildTarget, BuildTarget)] -disambiguateBuildTargets pkgid original = - disambiguate (userTargetQualLevel original) - where - disambiguate ql ts - | null amb = unamb - | otherwise = unamb ++ disambiguate (succ ql) amb - where - (amb, unamb) = step ql ts - - userTargetQualLevel (UserBuildTargetSingle _ ) = QL1 - userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2 - userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 - - step :: QualLevel -> [BuildTarget] - -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) - step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) - . partition (\g -> length g > 1) - . groupBy (equating fst) - . sortBy (comparing fst) - . map (\t -> (renderBuildTarget ql t pkgid, t)) - -data QualLevel = QL1 | QL2 | QL3 - deriving (Enum, Show) - -renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget -renderBuildTarget ql target pkgid = - case ql of - QL1 -> UserBuildTargetSingle s1 where s1 = single target - QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target - QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target - - where - single (BuildTargetComponent cn ) = dispCName cn - single (BuildTargetModule _ m) = prettyShow m - single (BuildTargetFile _ f) = f - - double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn) - double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) - double (BuildTargetFile cn f) = (dispCName cn, f) - - triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent" - triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) - triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) - - dispCName = componentStringName pkgid - dispKind = showComponentKindShort . componentKind - -reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () -reportBuildTargetProblems verbosity problems = do - - case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unrecognised build target '" ++ showUserBuildTarget target - ++ "'.\n" - ++ "Expected a " ++ intercalate " or " expected - ++ ", rather than '" ++ got ++ "'." - | (target, expected, got) <- targets ] - - case [ (t, e) | BuildTargetNoSuch t e <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Unknown build target '" ++ showUserBuildTarget target - ++ "'.\nThere is no " - ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" - | (thing, got) <- nosuch ] ++ "." - | (target, nosuch) <- targets ] - where - mungeThing "file" = "file target" - mungeThing thing = thing - - case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of - [] -> return () - targets -> - die' verbosity $ unlines - [ "Ambiguous build target '" ++ showUserBuildTarget target - ++ "'. It could be:\n " - ++ unlines [ " "++ showUserBuildTarget ut ++ - " (" ++ showBuildTargetKind bt ++ ")" - | (ut, bt) <- amb ] - | (target, amb) <- targets ] - - where - showBuildTargetKind (BuildTargetComponent _ ) = "component" - showBuildTargetKind (BuildTargetModule _ _) = "module" - showBuildTargetKind (BuildTargetFile _ _) = "file" - - ----------------------------------- --- Top level BuildTarget matcher --- - -matchBuildTarget :: PackageDescription - -> UserBuildTarget -> Bool -> Match BuildTarget -matchBuildTarget pkg = \utarget fexists -> - case utarget of - UserBuildTargetSingle str1 -> - matchBuildTarget1 cinfo str1 fexists - - UserBuildTargetDouble str1 str2 -> - matchBuildTarget2 cinfo str1 str2 fexists - - UserBuildTargetTriple str1 str2 str3 -> - matchBuildTarget3 cinfo str1 str2 str3 fexists - where - cinfo = pkgComponentInfo pkg - -matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchBuildTarget1 cinfo str1 fexists = - matchComponent1 cinfo str1 - `matchPlusShadowing` matchModule1 cinfo str1 - `matchPlusShadowing` matchFile1 cinfo str1 fexists - - -matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget2 cinfo str1 str2 fexists = - matchComponent2 cinfo str1 str2 - `matchPlusShadowing` matchModule2 cinfo str1 str2 - `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists - - -matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchBuildTarget3 cinfo str1 str2 str3 fexists = - matchModule3 cinfo str1 str2 str3 - `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists - - -data ComponentInfo = ComponentInfo { - cinfoName :: ComponentName, - cinfoStrName :: ComponentStringName, - cinfoSrcDirs :: [FilePath], - cinfoModules :: [ModuleName], - cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) - cinfoAsmFiles:: [FilePath], - cinfoCmmFiles:: [FilePath], - cinfoCFiles :: [FilePath], - cinfoCxxFiles:: [FilePath], - cinfoJsFiles :: [FilePath] - } - -type ComponentStringName = String - -pkgComponentInfo :: PackageDescription -> [ComponentInfo] -pkgComponentInfo pkg = - [ ComponentInfo { - cinfoName = componentName c, - cinfoStrName = componentStringName pkg (componentName c), - cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi, - cinfoModules = componentModules c, - cinfoHsFiles = componentHsFiles c, - cinfoAsmFiles= asmSources bi, - cinfoCmmFiles= cmmSources bi, - cinfoCFiles = cSources bi, - cinfoCxxFiles= cxxSources bi, - cinfoJsFiles = jsSources bi - } - | c <- pkgComponents pkg - , let bi = componentBuildInfo c ] - -componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName -componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg) -componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name -componentStringName _ (CFLibName name) = unUnqualComponentName name -componentStringName _ (CExeName name) = unUnqualComponentName name -componentStringName _ (CTestName name) = unUnqualComponentName name -componentStringName _ (CBenchName name) = unUnqualComponentName name - -componentModules :: Component -> [ModuleName] --- TODO: Use of 'explicitLibModules' here is a bit wrong: --- a user could very well ask to build a specific signature --- that was inherited from other packages. To fix this --- we have to plumb 'LocalBuildInfo' through this code. --- Fortunately, this is only used by 'pkgComponentInfo' --- Please don't export this function unless you plan on fixing --- this. -componentModules (CLib lib) = explicitLibModules lib -componentModules (CFLib flib) = foreignLibModules flib -componentModules (CExe exe) = exeModules exe -componentModules (CTest test) = testModules test -componentModules (CBench bench) = benchmarkModules bench - -componentHsFiles :: Component -> [FilePath] -componentHsFiles (CExe exe) = [modulePath exe] -componentHsFiles (CTest TestSuite { - testInterface = TestSuiteExeV10 _ mainfile - }) = [mainfile] -componentHsFiles (CBench Benchmark { - benchmarkInterface = BenchmarkExeV10 _ mainfile - }) = [mainfile] -componentHsFiles _ = [] - -{- -ex_cs :: [ComponentInfo] -ex_cs = - [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) - , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) - ] - where - mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) - mkMn :: String -> ModuleName - mkMn = fromJust . simpleParse - pkgid :: PackageIdentifier - Just pkgid = simpleParse "thelib" --} - ------------------------------- --- Matching component kinds --- - -data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind - deriving (Eq, Ord, Show, Enum, Bounded) - -componentKind :: ComponentName -> ComponentKind -componentKind (CLibName _) = LibKind -componentKind (CFLibName _) = FLibKind -componentKind (CExeName _) = ExeKind -componentKind (CTestName _) = TestKind -componentKind (CBenchName _) = BenchKind - -cinfoKind :: ComponentInfo -> ComponentKind -cinfoKind = componentKind . cinfoName - -matchComponentKind :: String -> Match ComponentKind -matchComponentKind s - | s `elem` ["lib", "library"] = return' LibKind - | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind - | s `elem` ["exe", "executable"] = return' ExeKind - | s `elem` ["tst", "test", "test-suite"] = return' TestKind - | s `elem` ["bench", "benchmark"] = return' BenchKind - | otherwise = matchErrorExpected "component kind" s - where - return' ck = increaseConfidence >> return ck - -showComponentKind :: ComponentKind -> String -showComponentKind LibKind = "library" -showComponentKind FLibKind = "foreign-library" -showComponentKind ExeKind = "executable" -showComponentKind TestKind = "test-suite" -showComponentKind BenchKind = "benchmark" - -showComponentKindShort :: ComponentKind -> String -showComponentKindShort LibKind = "lib" -showComponentKindShort FLibKind = "flib" -showComponentKindShort ExeKind = "exe" -showComponentKindShort TestKind = "test" -showComponentKindShort BenchKind = "bench" - ------------------------------- --- Matching component targets --- - -matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget -matchComponent1 cs = \str1 -> do - guardComponentName str1 - c <- matchComponentName cs str1 - return (BuildTargetComponent (cinfoName c)) - -matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchComponent2 cs = \str1 str2 -> do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - return (BuildTargetComponent (cinfoName c)) - --- utils: - -guardComponentName :: String -> Match () -guardComponentName s - | all validComponentChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "component name" s - where - validComponentChar c = isAlphaNum c || c == '.' - || c == '_' || c == '-' || c == '\'' - -matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo -matchComponentName cs str = - orNoSuchThing "component" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (cinfoStrName c, c) | c <- cs ] - str - -matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String - -> Match ComponentInfo -matchComponentKindAndName cs ckind str = - orNoSuchThing (showComponentKind ckind ++ " component") str - $ increaseConfidenceFor - $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) - [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ] - (ckind, str) - - ------------------------------- --- Matching module targets --- - -matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget -matchModule1 cs = \str1 -> do - guardModuleName str1 - nubMatchErrors $ do - c <- tryEach cs - let ms = cinfoModules c - m <- matchModuleName ms str1 - return (BuildTargetModule (cinfoName c) m) - -matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget -matchModule2 cs = \str1 str2 -> do - guardComponentName str1 - guardModuleName str2 - c <- matchComponentName cs str1 - let ms = cinfoModules c - m <- matchModuleName ms str2 - return (BuildTargetModule (cinfoName c) m) - -matchModule3 :: [ComponentInfo] -> String -> String -> String - -> Match BuildTarget -matchModule3 cs str1 str2 str3 = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - guardModuleName str3 - let ms = cinfoModules c - m <- matchModuleName ms str3 - return (BuildTargetModule (cinfoName c) m) - --- utils: - -guardModuleName :: String -> Match () -guardModuleName s - | all validModuleChar s - && not (null s) = increaseConfidence - | otherwise = matchErrorExpected "module name" s - where - validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' - -matchModuleName :: [ModuleName] -> String -> Match ModuleName -matchModuleName ms str = - orNoSuchThing "module" str - $ increaseConfidenceFor - $ matchInexactly caseFold - [ (prettyShow m, m) - | m <- ms ] - str - - ------------------------------- --- Matching file targets --- - -matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget -matchFile1 cs str1 exists = - nubMatchErrors $ do - c <- tryEach cs - filepath <- matchComponentFile c str1 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget -matchFile2 cs str1 str2 exists = do - guardComponentName str1 - c <- matchComponentName cs str1 - filepath <- matchComponentFile c str2 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool - -> Match BuildTarget -matchFile3 cs str1 str2 str3 exists = do - ckind <- matchComponentKind str1 - guardComponentName str2 - c <- matchComponentKindAndName cs ckind str2 - filepath <- matchComponentFile c str3 exists - return (BuildTargetFile (cinfoName c) filepath) - - -matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath -matchComponentFile c str fexists = - expecting "file" str $ - matchPlus - (matchFileExists str fexists) - (matchPlusShadowing - (msum [ matchModuleFileRooted dirs ms str - , matchOtherFileRooted dirs hsFiles str ]) - (msum [ matchModuleFileUnrooted ms str - , matchOtherFileUnrooted hsFiles str - , matchOtherFileUnrooted cFiles str - , matchOtherFileUnrooted jsFiles str ])) - where - dirs = cinfoSrcDirs c - ms = cinfoModules c - hsFiles = cinfoHsFiles c - cFiles = cinfoCFiles c - jsFiles = cinfoJsFiles c - - --- utils - -matchFileExists :: FilePath -> Bool -> Match a -matchFileExists _ False = mzero -matchFileExists fname True = do increaseConfidence - matchErrorNoSuch "file" fname - -matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath -matchModuleFileUnrooted ms str = do - let filepath = normalise str - _ <- matchModuleFileStem ms filepath - return filepath - -matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath -matchModuleFileRooted dirs ms str = nubMatches $ do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchModuleFileStem ms filepath' - return filepath - -matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName -matchModuleFileStem ms = - increaseConfidenceFor - . matchInexactly caseFold - [ (toFilePath m, m) | m <- ms ] - . dropExtension - -matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath -matchOtherFileRooted dirs fs str = do - let filepath = normalise str - filepath' <- matchDirectoryPrefix dirs filepath - _ <- matchFile fs filepath' - return filepath - -matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath -matchOtherFileUnrooted fs str = do - let filepath = normalise str - _ <- matchFile fs filepath - return filepath - -matchFile :: [FilePath] -> FilePath -> Match FilePath -matchFile fs = increaseConfidenceFor - . matchInexactly caseFold [ (f, f) | f <- fs ] - -matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath -matchDirectoryPrefix dirs filepath = - exactMatches $ - catMaybes - [ stripDirectory (normalise dir) filepath | dir <- dirs ] - where - stripDirectory :: FilePath -> FilePath -> Maybe FilePath - stripDirectory dir fp = - joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) - - ------------------------------- --- Matching monad --- - --- | A matcher embodies a way to match some input as being some recognised --- value. In particular it deals with multiple and ambiguous matches. --- --- There are various matcher primitives ('matchExactly', 'matchInexactly'), --- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can --- run a matcher against an input using 'findMatch'. --- - -data Match a = NoMatch Confidence [MatchError] - | ExactMatch Confidence [a] - | InexactMatch Confidence [a] - deriving Show - -type Confidence = Int - -data MatchError = MatchErrorExpected String String - | MatchErrorNoSuch String String - deriving (Show, Eq) - - -instance Alternative Match where - empty = mzero - (<|>) = mplus - -instance MonadPlus Match where - mzero = matchZero - mplus = matchPlus - -matchZero :: Match a -matchZero = NoMatch 0 [] - --- | Combine two matchers. Exact matches are used over inexact matches --- but if we have multiple exact, or inexact then the we collect all the --- ambiguous matches. --- -matchPlus :: Match a -> Match a -> Match a -matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = - ExactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a -matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = - InexactMatch (max d1 d2) (xs ++ xs') -matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a -matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b -matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b -matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') - | d1 > d2 = a - | d1 < d2 = b - | otherwise = NoMatch d1 (ms ++ ms') - --- | Combine two matchers. This is similar to 'ambiguousWith' with the --- difference that an exact match from the left matcher shadows any exact --- match on the right. Inexact matches are still collected however. --- -matchPlusShadowing :: Match a -> Match a -> Match a -matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a -matchPlusShadowing a b = matchPlus a b - -instance Functor Match where - fmap _ (NoMatch d ms) = NoMatch d ms - fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) - fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) - -instance Applicative Match where - pure a = ExactMatch 0 [a] - (<*>) = ap - -instance Monad Match where - return = pure - - NoMatch d ms >>= _ = NoMatch d ms - ExactMatch d xs >>= f = addDepth d - $ foldr matchPlus matchZero (map f xs) - InexactMatch d xs >>= f = addDepth d . forceInexact - $ foldr matchPlus matchZero (map f xs) - -addDepth :: Confidence -> Match a -> Match a -addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs -addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs -addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs - -forceInexact :: Match a -> Match a -forceInexact (ExactMatch d ys) = InexactMatch d ys -forceInexact m = m - ------------------------------- --- Various match primitives --- - -matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a -matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] -matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] - -expecting :: String -> String -> Match a -> Match a -expecting thing got (NoMatch 0 _) = matchErrorExpected thing got -expecting _ _ m = m - -orNoSuchThing :: String -> String -> Match a -> Match a -orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got -orNoSuchThing _ _ m = m - -increaseConfidence :: Match () -increaseConfidence = ExactMatch 1 [()] - -increaseConfidenceFor :: Match a -> Match a -increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r - -nubMatches :: Eq a => Match a -> Match a -nubMatches (NoMatch d msgs) = NoMatch d msgs -nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) -nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) - -nubMatchErrors :: Match a -> Match a -nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) -nubMatchErrors (ExactMatch d xs) = ExactMatch d xs -nubMatchErrors (InexactMatch d xs) = InexactMatch d xs - --- | Lift a list of matches to an exact match. --- -exactMatches, inexactMatches :: [a] -> Match a - -exactMatches [] = matchZero -exactMatches xs = ExactMatch 0 xs - -inexactMatches [] = matchZero -inexactMatches xs = InexactMatch 0 xs - -tryEach :: [a] -> Match a -tryEach = exactMatches - - ------------------------------- --- Top level match runner --- - --- | Given a matcher and a key to look up, use the matcher to find all the --- possible matches. There may be 'None', a single 'Unambiguous' match or --- you may have an 'Ambiguous' match with several possibilities. --- -findMatch :: Eq b => Match b -> MaybeAmbiguous b -findMatch match = - case match of - NoMatch _ msgs -> None (nub msgs) - ExactMatch _ xs -> checkAmbiguous xs - InexactMatch _ xs -> checkAmbiguous xs - where - checkAmbiguous xs = case nub xs of - [x] -> Unambiguous x - xs' -> Ambiguous xs' - -data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] - deriving Show - - ------------------------------- --- Basic matchers --- - -{- --- | A primitive matcher that looks up a value in a finite 'Map'. The --- value must match exactly. --- -matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) -matchExactly xs = - \x -> case Map.lookup x m of - Nothing -> matchZero - Just ys -> ExactMatch 0 ys - where - m :: Ord a => Map a [b] - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] --} - --- | A primitive matcher that looks up a value in a finite 'Map'. It checks --- for an exact or inexact match. We get an inexact match if the match --- is not exact, but the canonical forms match. It takes a canonicalisation --- function for this purpose. --- --- So for example if we used string case fold as the canonicalisation --- function, then we would get case insensitive matching (but it will still --- report an exact match when the case matches too). --- -matchInexactly :: (Ord a, Ord a') => - (a -> a') -> - [(a, b)] -> (a -> Match b) -matchInexactly cannonicalise xs = - \x -> case Map.lookup x m of - Just ys -> exactMatches ys - Nothing -> case Map.lookup (cannonicalise x) m' of - Just ys -> inexactMatches ys - Nothing -> matchZero - where - m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] - - -- the map of canonicalised keys to groups of inexact matches - m' = Map.mapKeysWith (++) cannonicalise m - - - ------------------------------- --- Utils --- - -caseFold :: String -> String -caseFold = lowercase - - --- | Check that the given build targets are valid in the current context. --- --- Also swizzle into a more convenient form. --- -checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget] - -> IO [TargetInfo] -checkBuildTargets _ pkg_descr lbi [] = - return (allTargetsInBuildOrder' pkg_descr lbi) - -checkBuildTargets verbosity pkg_descr lbi targets = do - - let (enabled, disabled) = - partitionEithers - [ case componentDisabledReason (componentEnabledSpec lbi) comp of - Nothing -> Left target' - Just reason -> Right (cname, reason) - | target <- targets - , let target'@(cname,_) = swizzleTarget target - , let comp = getComponent pkg_descr cname ] - - case disabled of - [] -> return () - ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason - - for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) -> - warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole " - ++ showComponentName c ++ " will be processed. (Support for " - ++ "module and file targets has not been implemented yet.)" - - -- Pick out the actual CLBIs for each of these cnames - enabled' <- for enabled $ \(cname, _) -> do - case componentNameTargets' pkg_descr lbi cname of - [] -> error "checkBuildTargets: nothing enabled" - [target] -> return target - _targets -> error "checkBuildTargets: multiple copies enabled" - - return enabled' - - where - swizzleTarget (BuildTargetComponent c) = (c, Nothing) - swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) - swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) - - formatReason cn DisabledComponent = - "Cannot process the " ++ cn ++ " because the component is marked " - ++ "as disabled in the .cabal file." - formatReason cn DisabledAllTests = - "Cannot process the " ++ cn ++ " because test suites are not " - ++ "enabled. Run configure with the flag --enable-tests" - formatReason cn DisabledAllBenchmarks = - "Cannot process the " ++ cn ++ " because benchmarks are not " - ++ "enabled. Re-run configure with the flag --enable-benchmarks" - formatReason cn (DisabledAllButOne cn') = - "Cannot process the " ++ cn ++ " because this package was " - ++ "configured only to build " ++ cn' ++ ". Re-run configure " - ++ "with the argument " ++ cn +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Client.BuildTargets +-- Copyright : (c) Duncan Coutts 2012 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified build targets +module Distribution.Simple.BuildTarget + ( -- * Main interface + readTargetInfos + , readBuildTargets -- in case you don't have LocalBuildInfo + + -- * Build targets + , BuildTarget (..) + , showBuildTarget + , QualLevel (..) + , buildTargetComponentName + + -- * Parsing user build targets + , UserBuildTarget + , readUserBuildTargets + , showUserBuildTarget + , UserBuildTargetProblem (..) + , reportUserBuildTargetProblems + + -- * Resolving build targets + , resolveBuildTargets + , BuildTargetProblem (..) + , reportBuildTargetProblems + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Compat.CharParsing as P +import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Utils +import Distribution.Utils.Path +import Distribution.Verbosity + +import Control.Arrow ((&&&)) +import Control.Monad (msum) +import Data.List (groupBy, stripPrefix) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map as Map +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath as FilePath + ( dropExtension + , hasTrailingPathSeparator + , joinPath + , normalise + , splitDirectories + , splitPath + ) + +-- | Take a list of 'String' build targets, and parse and validate them +-- into actual 'TargetInfo's to be built/registered/whatever. +readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo] +readTargetInfos verbosity pkg_descr lbi args = do + build_targets <- readBuildTargets verbosity pkg_descr args + checkBuildTargets verbosity pkg_descr lbi build_targets + +-- ------------------------------------------------------------ + +-- * User build targets + +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a build target. +data UserBuildTarget + = -- | A target specified by a single name. This could be a component + -- module or file. + -- + -- > cabal build foo + -- > cabal build Data.Foo + -- > cabal build Data/Foo.hs Data/Foo.hsc + UserBuildTargetSingle String + | -- | A target specified by a qualifier and name. This could be a component + -- name qualified by the component namespace kind, or a module or file + -- qualified by the component name. + -- + -- > cabal build lib:foo exe:foo + -- > cabal build foo:Data.Foo + -- > cabal build foo:Data/Foo.hs + UserBuildTargetDouble String String + | -- | A fully qualified target, either a module or file qualified by a + -- component name with the component namespace kind. + -- + -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs + -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo + UserBuildTargetTriple String String String + deriving (Show, Eq, Ord) + +-- ------------------------------------------------------------ + +-- * Resolved build targets + +-- ------------------------------------------------------------ + +-- | A fully resolved build target. +data BuildTarget + = -- | A specific component + BuildTargetComponent ComponentName + | -- | A specific module within a specific component. + BuildTargetModule ComponentName ModuleName + | -- | A specific file within a specific component. + BuildTargetFile ComponentName FilePath + deriving (Eq, Show, Generic) + +instance Binary BuildTarget + +buildTargetComponentName :: BuildTarget -> ComponentName +buildTargetComponentName (BuildTargetComponent cn) = cn +buildTargetComponentName (BuildTargetModule cn _) = cn +buildTargetComponentName (BuildTargetFile cn _) = cn + +-- | Read a list of user-supplied build target strings and resolve them to +-- 'BuildTarget's according to a 'PackageDescription'. If there are problems +-- with any of the targets e.g. they don't exist or are misformatted, throw an +-- 'IOException'. +readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget] +readBuildTargets verbosity pkg targetStrs = do + let (uproblems, utargets) = readUserBuildTargets targetStrs + reportUserBuildTargetProblems verbosity uproblems + + utargets' <- traverse checkTargetExistsAsFile utargets + + let (bproblems, btargets) = resolveBuildTargets pkg utargets' + reportBuildTargetProblems verbosity bproblems + + return btargets + +checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool) +checkTargetExistsAsFile t = do + fexists <- existsAsFile (fileComponentOfTarget t) + return (t, fexists) + where + existsAsFile f = do + exists <- doesFileExist f + case splitPath f of + (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d + (d : _ : _) | not exists -> doesDirectoryExist d + _ -> return exists + + fileComponentOfTarget (UserBuildTargetSingle s1) = s1 + fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2 + fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3 + +-- ------------------------------------------------------------ + +-- * Parsing user targets + +-- ------------------------------------------------------------ + +readUserBuildTargets + :: [String] + -> ( [UserBuildTargetProblem] + , [UserBuildTarget] + ) +readUserBuildTargets = partitionEithers . map readUserBuildTarget + +-- | +-- +-- >>> readUserBuildTarget "comp" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:comp" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "\"comp\"" +-- Right (UserBuildTargetSingle "comp") +-- +-- >>> readUserBuildTarget "lib:\"comp\"" +-- Right (UserBuildTargetDouble "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:\"comp\"" +-- Right (UserBuildTargetTriple "pkg" "lib" "comp") +-- +-- >>> readUserBuildTarget "pkg:lib:comp:more" +-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more") +-- +-- >>> readUserBuildTarget "pkg:\"lib\":comp" +-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp") +readUserBuildTarget + :: String + -> Either + UserBuildTargetProblem + UserBuildTarget +readUserBuildTarget targetstr = + case explicitEitherParsec parseTargetApprox targetstr of + Left _ -> Left (UserBuildTargetUnrecognised targetstr) + Right tgt -> Right tgt + where + parseTargetApprox :: CabalParsing m => m UserBuildTarget + parseTargetApprox = do + -- read one, two, or three tokens, where last could be "hs-string" + ts <- tokens + return $ case ts of + (a, Nothing) -> UserBuildTargetSingle a + (a, Just (b, Nothing)) -> UserBuildTargetDouble a b + (a, Just (b, Just c)) -> UserBuildTargetTriple a b c + + tokens :: CabalParsing m => m (String, Maybe (String, Maybe String)) + tokens = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2) + + tokens2 :: CabalParsing m => m (String, Maybe String) + tokens2 = + (\s -> (s, Nothing)) <$> parsecHaskellString + <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token)) + + token :: CabalParsing m => m String + token = P.munch1 (\x -> not (isSpace x) && x /= ':') + +data UserBuildTargetProblem + = UserBuildTargetUnrecognised String + deriving (Show) + +reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO () +reportUserBuildTargetProblems verbosity problems = do + case [target | UserBuildTargetUnrecognised target <- problems] of + [] -> return () + target -> + dieWithException verbosity $ + UnrecognisedBuildTarget target + +showUserBuildTarget :: UserBuildTarget -> String +showUserBuildTarget = intercalate ":" . getComponents + where + getComponents (UserBuildTargetSingle s1) = [s1] + getComponents (UserBuildTargetDouble s1 s2) = [s1, s2] + getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3] + +-- | Unless you use 'QL1', this function is PARTIAL; +-- use 'showBuildTarget' instead. +showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String +showBuildTarget' ql pkgid bt = + showUserBuildTarget (renderBuildTarget ql bt pkgid) + +-- | Unambiguously render a 'BuildTarget', so that it can +-- be parsed in all situations. +showBuildTarget :: PackageId -> BuildTarget -> String +showBuildTarget pkgid t = + showBuildTarget' (qlBuildTarget t) pkgid t + where + qlBuildTarget BuildTargetComponent{} = QL2 + qlBuildTarget _ = QL3 + +-- ------------------------------------------------------------ + +-- * Resolving user targets to build targets + +-- ------------------------------------------------------------ + +{- +stargets = + [ BuildTargetComponent (CExeName "foo") + , BuildTargetModule (CExeName "foo") (mkMn "Foo") + , BuildTargetModule (CExeName "tst") (mkMn "Foo") + ] + where + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + +ex_pkgid :: PackageIdentifier +Just ex_pkgid = simpleParse "thelib" +-} + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. +resolveBuildTargets + :: PackageDescription + -> [(UserBuildTarget, Bool)] + -> ([BuildTargetProblem], [BuildTarget]) +resolveBuildTargets pkg = + partitionEithers + . map (uncurry (resolveBuildTarget pkg)) + +resolveBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Either BuildTargetProblem BuildTarget +resolveBuildTarget pkg userTarget fexists = + case findMatch (matchBuildTarget pkg userTarget fexists) of + Unambiguous target -> Right target + Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets') + where + targets' = + disambiguateBuildTargets + (packageId pkg) + userTarget + targets + None errs -> Left (classifyMatchErrors errs) + where + classifyMatchErrors errs + | Just expected' <- NE.nonEmpty expected = + let unzip' = fmap fst &&& fmap snd + (things, got :| _) = unzip' expected' + in BuildTargetExpected userTarget (NE.toList things) got + | not (null nosuch) = BuildTargetNoSuch userTarget nosuch + | otherwise = error $ "resolveBuildTarget: internal error in matching" + where + expected = [(thing, got) | MatchErrorExpected thing got <- errs] + nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs] + +data BuildTargetProblem + = -- | [expected thing] (actually got) + BuildTargetExpected UserBuildTarget [String] String + | -- | [(no such thing, actually got)] + BuildTargetNoSuch UserBuildTarget [(String, String)] + | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)] + deriving (Show) + +disambiguateBuildTargets + :: PackageId + -> UserBuildTarget + -> [BuildTarget] + -> [(UserBuildTarget, BuildTarget)] +disambiguateBuildTargets pkgid original = + disambiguate (userTargetQualLevel original) + where + disambiguate ql ts + | null amb = unamb + | otherwise = unamb ++ disambiguate (succ ql) amb + where + (amb, unamb) = step ql ts + + userTargetQualLevel (UserBuildTargetSingle _) = QL1 + userTargetQualLevel (UserBuildTargetDouble _ _) = QL2 + userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3 + + step + :: QualLevel + -> [BuildTarget] + -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]) + step ql = + (\(amb, unamb) -> (map snd $ concat amb, concat unamb)) + . partition (\g -> length g > 1) + . groupBy (equating fst) + . sortBy (comparing fst) + . map (\t -> (renderBuildTarget ql t pkgid, t)) + +data QualLevel = QL1 | QL2 | QL3 + deriving (Enum, Show) + +renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget +renderBuildTarget ql target pkgid = + case ql of + QL1 -> UserBuildTargetSingle s1 where s1 = single target + QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target + QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target + where + single (BuildTargetComponent cn) = dispCName cn + single (BuildTargetModule _ m) = prettyShow m + single (BuildTargetFile _ f) = f + + double (BuildTargetComponent cn) = (dispKind cn, dispCName cn) + double (BuildTargetModule cn m) = (dispCName cn, prettyShow m) + double (BuildTargetFile cn f) = (dispCName cn, f) + + triple (BuildTargetComponent _) = error "triple BuildTargetComponent" + triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m) + triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f) + + dispCName = componentStringName pkgid + dispKind = showComponentKindShort . componentKind + +reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO () +reportBuildTargetProblems verbosity problems = do + case [(t, e, g) | BuildTargetExpected t e g <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + ReportBuildTargetProblems $ + map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets + + case [(t, e) | BuildTargetNoSuch t e <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + UnknownBuildTarget $ + map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets + + case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of + [] -> return () + targets -> + dieWithException verbosity $ + AmbiguousBuildTarget $ + map + ( \(target, amb) -> + ( showUserBuildTarget target + , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb) + ) + ) + targets + where + showBuildTargetKind (BuildTargetComponent _) = "component" + showBuildTargetKind (BuildTargetModule _ _) = "module" + showBuildTargetKind (BuildTargetFile _ _) = "file" + +---------------------------------- +-- Top level BuildTarget matcher +-- + +matchBuildTarget + :: PackageDescription + -> UserBuildTarget + -> Bool + -> Match BuildTarget +matchBuildTarget pkg = \utarget fexists -> + case utarget of + UserBuildTargetSingle str1 -> + matchBuildTarget1 cinfo str1 fexists + UserBuildTargetDouble str1 str2 -> + matchBuildTarget2 cinfo str1 str2 fexists + UserBuildTargetTriple str1 str2 str3 -> + matchBuildTarget3 cinfo str1 str2 str3 fexists + where + cinfo = pkgComponentInfo pkg + +matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchBuildTarget1 cinfo str1 fexists = + matchComponent1 cinfo str1 + `matchPlusShadowing` matchModule1 cinfo str1 + `matchPlusShadowing` matchFile1 cinfo str1 fexists + +matchBuildTarget2 + :: [ComponentInfo] + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget2 cinfo str1 str2 fexists = + matchComponent2 cinfo str1 str2 + `matchPlusShadowing` matchModule2 cinfo str1 str2 + `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists + +matchBuildTarget3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchBuildTarget3 cinfo str1 str2 str3 fexists = + matchModule3 cinfo str1 str2 str3 + `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists + +data ComponentInfo = ComponentInfo + { cinfoName :: ComponentName + , cinfoStrName :: ComponentStringName + , cinfoSrcDirs :: [FilePath] + , cinfoModules :: [ModuleName] + , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs) + , cinfoAsmFiles :: [FilePath] + , cinfoCmmFiles :: [FilePath] + , cinfoCFiles :: [FilePath] + , cinfoCxxFiles :: [FilePath] + , cinfoJsFiles :: [FilePath] + } + +type ComponentStringName = String + +pkgComponentInfo :: PackageDescription -> [ComponentInfo] +pkgComponentInfo pkg = + [ ComponentInfo + { cinfoName = componentName c + , cinfoStrName = componentStringName pkg (componentName c) + , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi + , cinfoModules = componentModules c + , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c + , cinfoAsmFiles = map getSymbolicPath $ asmSources bi + , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi + , cinfoCFiles = map getSymbolicPath $ cSources bi + , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi + , cinfoJsFiles = map getSymbolicPath $ jsSources bi + } + | c <- pkgComponents pkg + , let bi = componentBuildInfo c + ] + +componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName +componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg) +componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name +componentStringName _ (CFLibName name) = unUnqualComponentName name +componentStringName _ (CExeName name) = unUnqualComponentName name +componentStringName _ (CTestName name) = unUnqualComponentName name +componentStringName _ (CBenchName name) = unUnqualComponentName name + +componentModules :: Component -> [ModuleName] +-- TODO: Use of 'explicitLibModules' here is a bit wrong: +-- a user could very well ask to build a specific signature +-- that was inherited from other packages. To fix this +-- we have to plumb 'LocalBuildInfo' through this code. +-- Fortunately, this is only used by 'pkgComponentInfo' +-- Please don't export this function unless you plan on fixing +-- this. +componentModules (CLib lib) = explicitLibModules lib +componentModules (CFLib flib) = foreignLibModules flib +componentModules (CExe exe) = exeModules exe +componentModules (CTest test) = testModules test +componentModules (CBench bench) = benchmarkModules bench + +componentHsFiles :: Component -> [RelativePath Source File] +componentHsFiles (CExe exe) = [modulePath exe] +componentHsFiles + ( CTest + TestSuite + { testInterface = TestSuiteExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles + ( CBench + Benchmark + { benchmarkInterface = BenchmarkExeV10 _ mainfile + } + ) = [mainfile] +componentHsFiles _ = [] + +{- +ex_cs :: [ComponentInfo] +ex_cs = + [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) + , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) + ] + where + mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms) + mkMn :: String -> ModuleName + mkMn = fromJust . simpleParse + pkgid :: PackageIdentifier + Just pkgid = simpleParse "thelib" +-} + +------------------------------ +-- Matching component kinds +-- + +data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind + deriving (Eq, Ord, Show, Enum, Bounded) + +componentKind :: ComponentName -> ComponentKind +componentKind (CLibName _) = LibKind +componentKind (CFLibName _) = FLibKind +componentKind (CExeName _) = ExeKind +componentKind (CTestName _) = TestKind +componentKind (CBenchName _) = BenchKind + +cinfoKind :: ComponentInfo -> ComponentKind +cinfoKind = componentKind . cinfoName + +matchComponentKind :: String -> Match ComponentKind +matchComponentKind s + | s `elem` ["lib", "library"] = return' LibKind + | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind + | s `elem` ["exe", "executable"] = return' ExeKind + | s `elem` ["tst", "test", "test-suite"] = return' TestKind + | s `elem` ["bench", "benchmark"] = return' BenchKind + | otherwise = matchErrorExpected "component kind" s + where + return' ck = increaseConfidence >> return ck + +showComponentKind :: ComponentKind -> String +showComponentKind LibKind = "library" +showComponentKind FLibKind = "foreign-library" +showComponentKind ExeKind = "executable" +showComponentKind TestKind = "test-suite" +showComponentKind BenchKind = "benchmark" + +showComponentKindShort :: ComponentKind -> String +showComponentKindShort LibKind = "lib" +showComponentKindShort FLibKind = "flib" +showComponentKindShort ExeKind = "exe" +showComponentKindShort TestKind = "test" +showComponentKindShort BenchKind = "bench" + +------------------------------ +-- Matching component targets +-- + +matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget +matchComponent1 cs = \str1 -> do + guardComponentName str1 + c <- matchComponentName cs str1 + return (BuildTargetComponent (cinfoName c)) + +matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchComponent2 cs = \str1 str2 -> do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + return (BuildTargetComponent (cinfoName c)) + +-- utils: + +guardComponentName :: String -> Match () +guardComponentName s + | all validComponentChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "component name" s + where + validComponentChar c = + isAlphaNum c + || c == '.' + || c == '_' + || c == '-' + || c == '\'' + +matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo +matchComponentName cs str = + orNoSuchThing "component" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [(cinfoStrName c, c) | c <- cs] + str + +matchComponentKindAndName + :: [ComponentInfo] + -> ComponentKind + -> String + -> Match ComponentInfo +matchComponentKindAndName cs ckind str = + orNoSuchThing (showComponentKind ckind ++ " component") str $ + increaseConfidenceFor $ + matchInexactly + (\(ck, cn) -> (ck, caseFold cn)) + [((cinfoKind c, cinfoStrName c), c) | c <- cs] + (ckind, str) + +------------------------------ +-- Matching module targets +-- + +matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget +matchModule1 cs = \str1 -> do + guardModuleName str1 + nubMatchErrors $ do + c <- tryEach cs + let ms = cinfoModules c + m <- matchModuleName ms str1 + return (BuildTargetModule (cinfoName c) m) + +matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget +matchModule2 cs = \str1 str2 -> do + guardComponentName str1 + guardModuleName str2 + c <- matchComponentName cs str1 + let ms = cinfoModules c + m <- matchModuleName ms str2 + return (BuildTargetModule (cinfoName c) m) + +matchModule3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Match BuildTarget +matchModule3 cs str1 str2 str3 = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + guardModuleName str3 + let ms = cinfoModules c + m <- matchModuleName ms str3 + return (BuildTargetModule (cinfoName c) m) + +-- utils: + +guardModuleName :: String -> Match () +guardModuleName s + | all validModuleChar s + && not (null s) = + increaseConfidence + | otherwise = matchErrorExpected "module name" s + where + validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' + +matchModuleName :: [ModuleName] -> String -> Match ModuleName +matchModuleName ms str = + orNoSuchThing "module" str $ + increaseConfidenceFor $ + matchInexactly + caseFold + [ (prettyShow m, m) + | m <- ms + ] + str + +------------------------------ +-- Matching file targets +-- + +matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget +matchFile1 cs str1 exists = + nubMatchErrors $ do + c <- tryEach cs + filepath <- matchComponentFile c str1 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget +matchFile2 cs str1 str2 exists = do + guardComponentName str1 + c <- matchComponentName cs str1 + filepath <- matchComponentFile c str2 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchFile3 + :: [ComponentInfo] + -> String + -> String + -> String + -> Bool + -> Match BuildTarget +matchFile3 cs str1 str2 str3 exists = do + ckind <- matchComponentKind str1 + guardComponentName str2 + c <- matchComponentKindAndName cs ckind str2 + filepath <- matchComponentFile c str3 exists + return (BuildTargetFile (cinfoName c) filepath) + +matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath +matchComponentFile c str fexists = + expecting "file" str $ + matchPlus + (matchFileExists str fexists) + ( matchPlusShadowing + ( msum + [ matchModuleFileRooted dirs ms str + , matchOtherFileRooted dirs hsFiles str + ] + ) + ( msum + [ matchModuleFileUnrooted ms str + , matchOtherFileUnrooted hsFiles str + , matchOtherFileUnrooted cFiles str + , matchOtherFileUnrooted jsFiles str + ] + ) + ) + where + dirs = cinfoSrcDirs c + ms = cinfoModules c + hsFiles = cinfoHsFiles c + cFiles = cinfoCFiles c + jsFiles = cinfoJsFiles c + +-- utils + +matchFileExists :: FilePath -> Bool -> Match a +matchFileExists _ False = mzero +matchFileExists fname True = do + increaseConfidence + matchErrorNoSuch "file" fname + +matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath +matchModuleFileUnrooted ms str = do + let filepath = normalise str + _ <- matchModuleFileStem ms filepath + return filepath + +matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath +matchModuleFileRooted dirs ms str = nubMatches $ do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchModuleFileStem ms filepath' + return filepath + +matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName +matchModuleFileStem ms = + increaseConfidenceFor + . matchInexactly + caseFold + [(toFilePath m, m) | m <- ms] + . dropExtension + +matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath +matchOtherFileRooted dirs fs str = do + let filepath = normalise str + filepath' <- matchDirectoryPrefix dirs filepath + _ <- matchFile fs filepath' + return filepath + +matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath +matchOtherFileUnrooted fs str = do + let filepath = normalise str + _ <- matchFile fs filepath + return filepath + +matchFile :: [FilePath] -> FilePath -> Match FilePath +matchFile fs = + increaseConfidenceFor + . matchInexactly caseFold [(f, f) | f <- fs] + +matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath +matchDirectoryPrefix dirs filepath = + exactMatches $ + catMaybes + [stripDirectory (normalise dir) filepath | dir <- dirs] + where + stripDirectory :: FilePath -> FilePath -> Maybe FilePath + stripDirectory dir fp = + joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp) + +------------------------------ +-- Matching monad +-- + +-- | A matcher embodies a way to match some input as being some recognised +-- value. In particular it deals with multiple and ambiguous matches. +-- +-- There are various matcher primitives ('matchExactly', 'matchInexactly'), +-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can +-- run a matcher against an input using 'findMatch'. +data Match a + = NoMatch Confidence [MatchError] + | ExactMatch Confidence [a] + | InexactMatch Confidence [a] + deriving (Show) + +type Confidence = Int + +data MatchError + = MatchErrorExpected String String + | MatchErrorNoSuch String String + deriving (Show, Eq) + +instance Alternative Match where + empty = mzero + (<|>) = mplus + +instance MonadPlus Match where + mzero = matchZero + mplus = matchPlus + +matchZero :: Match a +matchZero = NoMatch 0 [] + +-- | Combine two matchers. Exact matches are used over inexact matches +-- but if we have multiple exact, or inexact then the we collect all the +-- ambiguous matches. +matchPlus :: Match a -> Match a -> Match a +matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') = + ExactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a +matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a +matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b +matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') = + InexactMatch (max d1 d2) (xs ++ xs') +matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a +matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b +matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b +matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms') + | d1 > d2 = a + | d1 < d2 = b + | otherwise = NoMatch d1 (ms ++ ms') + +-- | Combine two matchers. This is similar to 'ambiguousWith' with the +-- difference that an exact match from the left matcher shadows any exact +-- match on the right. Inexact matches are still collected however. +matchPlusShadowing :: Match a -> Match a -> Match a +matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a +matchPlusShadowing a b = matchPlus a b + +instance Functor Match where + fmap _ (NoMatch d ms) = NoMatch d ms + fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs) + fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs) + +instance Applicative Match where + pure a = ExactMatch 0 [a] + (<*>) = ap + +instance Monad Match where + return = pure + + NoMatch d ms >>= _ = NoMatch d ms + ExactMatch d xs >>= f = + addDepth d $ + foldr matchPlus matchZero (map f xs) + InexactMatch d xs >>= f = + addDepth d . forceInexact $ + foldr matchPlus matchZero (map f xs) + +addDepth :: Confidence -> Match a -> Match a +addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs +addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs +addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs + +forceInexact :: Match a -> Match a +forceInexact (ExactMatch d ys) = InexactMatch d ys +forceInexact m = m + +------------------------------ +-- Various match primitives +-- + +matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a +matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] +matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got] + +expecting :: String -> String -> Match a -> Match a +expecting thing got (NoMatch 0 _) = matchErrorExpected thing got +expecting _ _ m = m + +orNoSuchThing :: String -> String -> Match a -> Match a +orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got +orNoSuchThing _ _ m = m + +increaseConfidence :: Match () +increaseConfidence = ExactMatch 1 [()] + +increaseConfidenceFor :: Match a -> Match a +increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r + +nubMatches :: Eq a => Match a -> Match a +nubMatches (NoMatch d msgs) = NoMatch d msgs +nubMatches (ExactMatch d xs) = ExactMatch d (nub xs) +nubMatches (InexactMatch d xs) = InexactMatch d (nub xs) + +nubMatchErrors :: Match a -> Match a +nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs) +nubMatchErrors (ExactMatch d xs) = ExactMatch d xs +nubMatchErrors (InexactMatch d xs) = InexactMatch d xs + +-- | Lift a list of matches to an exact match. +exactMatches, inexactMatches :: [a] -> Match a +exactMatches [] = matchZero +exactMatches xs = ExactMatch 0 xs +inexactMatches [] = matchZero +inexactMatches xs = InexactMatch 0 xs + +tryEach :: [a] -> Match a +tryEach = exactMatches + +------------------------------ +-- Top level match runner +-- + +-- | Given a matcher and a key to look up, use the matcher to find all the +-- possible matches. There may be 'None', a single 'Unambiguous' match or +-- you may have an 'Ambiguous' match with several possibilities. +findMatch :: Eq b => Match b -> MaybeAmbiguous b +findMatch match = + case match of + NoMatch _ msgs -> None (nub msgs) + ExactMatch _ xs -> checkAmbiguous xs + InexactMatch _ xs -> checkAmbiguous xs + where + checkAmbiguous xs = case nub xs of + [x] -> Unambiguous x + xs' -> Ambiguous xs' + +data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a] + deriving (Show) + +------------------------------ +-- Basic matchers +-- + +{- +-- | A primitive matcher that looks up a value in a finite 'Map'. The +-- value must match exactly. +-- +matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b) +matchExactly xs = + \x -> case Map.lookup x m of + Nothing -> matchZero + Just ys -> ExactMatch 0 ys + where + m :: Ord a => Map a [b] + m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ] +-} + +-- | A primitive matcher that looks up a value in a finite 'Map'. It checks +-- for an exact or inexact match. We get an inexact match if the match +-- is not exact, but the canonical forms match. It takes a canonicalisation +-- function for this purpose. +-- +-- So for example if we used string case fold as the canonicalisation +-- function, then we would get case insensitive matching (but it will still +-- report an exact match when the case matches too). +matchInexactly + :: (Ord a, Ord a') + => (a -> a') + -> [(a, b)] + -> (a -> Match b) +matchInexactly cannonicalise xs = + \x -> case Map.lookup x m of + Just ys -> exactMatches ys + Nothing -> case Map.lookup (cannonicalise x) m' of + Just ys -> inexactMatches ys + Nothing -> matchZero + where + m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs] + + -- the map of canonicalised keys to groups of inexact matches + m' = Map.mapKeysWith (++) cannonicalise m + +------------------------------ +-- Utils +-- + +caseFold :: String -> String +caseFold = lowercase + +-- | Check that the given build targets are valid in the current context. +-- +-- Also swizzle into a more convenient form. +checkBuildTargets + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> [BuildTarget] + -> IO [TargetInfo] +checkBuildTargets _ pkg_descr lbi [] = + return (allTargetsInBuildOrder' pkg_descr lbi) +checkBuildTargets + verbosity + pkg_descr + lbi@(LocalBuildInfo{componentEnabledSpec = enabledComps}) + targets = do + let (enabled, disabled) = + partitionEithers + [ case componentDisabledReason enabledComps comp of + Nothing -> Left target' + Just reason -> Right (cname, reason) + | target <- targets + , let target'@(cname, _) = swizzleTarget target + , let comp = getComponent pkg_descr cname + ] + + case disabled of + [] -> return () + ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason + + for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) -> + warn verbosity $ + "Ignoring '" + ++ either prettyShow id t + ++ ". The whole " + ++ showComponentName c + ++ " will be processed. (Support for " + ++ "module and file targets has not been implemented yet.)" + + -- Pick out the actual CLBIs for each of these cnames + enabled' <- for enabled $ \(cname, _) -> do + case componentNameTargets' pkg_descr lbi cname of + [] -> error "checkBuildTargets: nothing enabled" + [target] -> return target + _targets -> error "checkBuildTargets: multiple copies enabled" + + return enabled' + where + swizzleTarget (BuildTargetComponent c) = (c, Nothing) + swizzleTarget (BuildTargetModule c m) = (c, Just (Left m)) + swizzleTarget (BuildTargetFile c f) = (c, Just (Right f)) + + formatReason cn DisabledComponent = + "Cannot process the " + ++ cn + ++ " because the component is marked " + ++ "as disabled in the .cabal file." + formatReason cn DisabledAllTests = + "Cannot process the " + ++ cn + ++ " because test suites are not " + ++ "enabled. Run configure with the flag --enable-tests" + formatReason cn DisabledAllBenchmarks = + "Cannot process the " + ++ cn + ++ " because benchmarks are not " + ++ "enabled. Re-run configure with the flag --enable-benchmarks" + formatReason cn (DisabledAllButOne cn') = + "Cannot process the " + ++ cn + ++ " because this package was " + ++ "configured only to build " + ++ cn' + ++ ". Re-run configure " + ++ "with the argument " + ++ cn diff --git a/src/Distribution/Simple/BuildToolDepends.hs b/src/Distribution/Simple/BuildToolDepends.hs --- a/src/Distribution/Simple/BuildToolDepends.hs +++ b/src/Distribution/Simple/BuildToolDepends.hs @@ -5,18 +5,44 @@ -- the functions contained to access those fields directly. module Distribution.Simple.BuildToolDepends where -import Prelude () -import Distribution.Compat.Prelude +import Distribution.Compat.Prelude +import Prelude () import qualified Data.Map as Map -import Distribution.Package -import Distribution.PackageDescription +import Distribution.Package +import Distribution.PackageDescription --- | Desugar a "build-tools" entry into proper a executable dependency if +-- | Same as 'desugarBuildTool', but requires atomic information (package +-- name, executable names) instead of a whole 'PackageDescription'. +desugarBuildToolSimple + :: PackageName + -> [UnqualComponentName] + -> LegacyExeDependency + -> Maybe ExeDependency +desugarBuildToolSimple pname exeNames (LegacyExeDependency name reqVer) + | foundLocal = Just $ ExeDependency pname toolName reqVer + | otherwise = Map.lookup name allowMap + where + toolName = mkUnqualComponentName name + foundLocal = toolName `elem` exeNames + allowlist = + [ "hscolour" + , "haddock" + , "happy" + , "alex" + , "hsc2hs" + , "c2hs" + , "cpphs" + , "hspec-discover" + ] + allowMap = Map.fromList $ flip map allowlist $ \n -> + (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + +-- | Desugar a "build-tools" entry into a proper executable dependency if -- possible. -- --- An entry can be so desguared in two cases: +-- An entry can be so desugared in two cases: -- -- 1. The name in build-tools matches a locally defined executable. The -- executable dependency produced is on that exe in the current package. @@ -26,31 +52,25 @@ -- the same, but the hard-coding could just as well be per-key. -- -- The first cases matches first. -desugarBuildTool :: PackageDescription - -> LegacyExeDependency - -> Maybe ExeDependency +desugarBuildTool + :: PackageDescription + -> LegacyExeDependency + -> Maybe ExeDependency desugarBuildTool pkg led = - if foundLocal - then Just $ ExeDependency (packageName pkg) toolName reqVer - else Map.lookup name whiteMap - where - LegacyExeDependency name reqVer = led - toolName = mkUnqualComponentName name - foundLocal = toolName `elem` map exeName (executables pkg) - whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs" - , "cpphs", "greencard", "hspec-discover" - ] - whiteMap = Map.fromList $ flip map whitelist $ \n -> - (n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer) + desugarBuildToolSimple + (packageName pkg) + (map exeName $ executables pkg) + led -- | Get everything from "build-tool-depends", along with entries from -- "build-tools" that we know how to desugar. -- -- This should almost always be used instead of just accessing the -- `buildToolDepends` field directly. -getAllToolDependencies :: PackageDescription - -> BuildInfo - -> [ExeDependency] +getAllToolDependencies + :: PackageDescription + -> BuildInfo + -> [ExeDependency] getAllToolDependencies pkg bi = buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi) @@ -78,14 +98,14 @@ isInternal :: PackageDescription -> ExeDependency -> Bool isInternal pkg (ExeDependency n _ _) = n == packageName pkg - -- | Get internal "build-tool-depends", along with internal "build-tools" -- -- This is a tiny function, but used in a number of places. The same -- restrictions that apply to `isInternal` also apply to this function. -getAllInternalToolDependencies :: PackageDescription - -> BuildInfo - -> [UnqualComponentName] +getAllInternalToolDependencies + :: PackageDescription + -> BuildInfo + -> [UnqualComponentName] getAllInternalToolDependencies pkg bi = [ toolname | dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi diff --git a/src/Distribution/Simple/BuildWay.hs b/src/Distribution/Simple/BuildWay.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/BuildWay.hs @@ -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_" diff --git a/src/Distribution/Simple/CCompiler.hs b/src/Distribution/Simple/CCompiler.hs --- a/src/Distribution/Simple/CCompiler.hs +++ b/src/Distribution/Simple/CCompiler.hs @@ -1,14 +1,4 @@ ----------------------------------------------------------------------------- --- | --- Module : Distribution.Simple.CCompiler --- Copyright : 2011, Dan Knapp --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This simple package provides types and functions for interacting with --- C compilers. Currently it's just a type enumerating extant C-like --- languages, which we call dialects. {- Redistribution and use in source and binary forms, with or without @@ -39,85 +29,109 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} -module Distribution.Simple.CCompiler ( - CDialect(..), - cSourceExtensions, - cDialectFilenameExtension, - filenameCDialect +-- | +-- Module : Distribution.Simple.CCompiler +-- Copyright : 2011, Dan Knapp +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This simple package provides types and functions for interacting with +-- C compilers. Currently it's just a type enumerating extant C-like +-- languages, which we call dialects. +module Distribution.Simple.CCompiler + ( CDialect (..) + , cSourceExtensions + , cDialectFilenameExtension + , filenameCDialect ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import System.FilePath - ( takeExtension ) - + ( takeExtension + ) -- | Represents a dialect of C. The Monoid instance expresses backward -- compatibility, in the sense that 'mappend a b' is the least inclusive -- dialect which both 'a' and 'b' can be correctly interpreted as. -data CDialect = C - | ObjectiveC - | CPlusPlus - | ObjectiveCPlusPlus - deriving (Eq, Show) +data CDialect + = C + | ObjectiveC + | CPlusPlus + | ObjectiveCPlusPlus + deriving (Eq, Show) instance Monoid CDialect where mempty = C mappend = (<>) instance Semigroup CDialect where - C <> anything = anything - ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus - CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus - _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus - ObjectiveC <> _ = ObjectiveC - CPlusPlus <> _ = CPlusPlus - ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus + C <> anything = anything + ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus + CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus + _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus + ObjectiveC <> _ = ObjectiveC + CPlusPlus <> _ = CPlusPlus + ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus -- | A list of all file extensions which are recognized as possibly containing -- some dialect of C code. Note that this list is only for source files, -- not for header files. cSourceExtensions :: [String] -cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp", - "cxx", "cpp", "CPP", "c++", "C"] - +cSourceExtensions = + [ "c" + , "i" + , "ii" + , "m" + , "mi" + , "mm" + , "M" + , "mii" + , "cc" + , "cp" + , "cxx" + , "cpp" + , "CPP" + , "c++" + , "C" + ] -- | Takes a dialect of C and whether code is intended to be passed through -- the preprocessor, and returns a filename extension for containing that -- code. cDialectFilenameExtension :: CDialect -> Bool -> String -cDialectFilenameExtension C True = "c" +cDialectFilenameExtension C True = "c" cDialectFilenameExtension C False = "i" -cDialectFilenameExtension ObjectiveC True = "m" +cDialectFilenameExtension ObjectiveC True = "m" cDialectFilenameExtension ObjectiveC False = "mi" -cDialectFilenameExtension CPlusPlus True = "cpp" -cDialectFilenameExtension CPlusPlus False = "ii" -cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" +cDialectFilenameExtension CPlusPlus True = "cpp" +cDialectFilenameExtension CPlusPlus False = "ii" +cDialectFilenameExtension ObjectiveCPlusPlus True = "mm" cDialectFilenameExtension ObjectiveCPlusPlus False = "mii" - -- | Infers from a filename's extension the dialect of C which it contains, -- and whether it is intended to be passed through the preprocessor. filenameCDialect :: String -> Maybe (CDialect, Bool) filenameCDialect filename = do extension <- case takeExtension filename of - '.':ext -> Just ext - _ -> Nothing + '.' : ext -> Just ext + _ -> Nothing case extension of - "c" -> return (C, True) - "i" -> return (C, False) - "ii" -> return (CPlusPlus, False) - "m" -> return (ObjectiveC, True) - "mi" -> return (ObjectiveC, False) - "mm" -> return (ObjectiveCPlusPlus, True) - "M" -> return (ObjectiveCPlusPlus, True) + "c" -> return (C, True) + "i" -> return (C, False) + "ii" -> return (CPlusPlus, False) + "m" -> return (ObjectiveC, True) + "mi" -> return (ObjectiveC, False) + "mm" -> return (ObjectiveCPlusPlus, True) + "M" -> return (ObjectiveCPlusPlus, True) "mii" -> return (ObjectiveCPlusPlus, False) - "cc" -> return (CPlusPlus, True) - "cp" -> return (CPlusPlus, True) + "cc" -> return (CPlusPlus, True) + "cp" -> return (CPlusPlus, True) "cxx" -> return (CPlusPlus, True) "cpp" -> return (CPlusPlus, True) "CPP" -> return (CPlusPlus, True) "c++" -> return (CPlusPlus, True) - "C" -> return (CPlusPlus, True) - _ -> Nothing + "C" -> return (CPlusPlus, True) + _ -> Nothing diff --git a/src/Distribution/Simple/Command.hs b/src/Distribution/Simple/Command.hs --- a/src/Distribution/Simple/Command.hs +++ b/src/Distribution/Simple/Command.hs @@ -1,8 +1,11 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Command -- Copyright : Duncan Coutts 2007 @@ -18,88 +21,103 @@ -- run. It handles some common stuff automatically, like the @--help@ and -- command line completion flags. It is designed to allow other tools make -- derived commands. This feature is used heavily in @cabal-install@. - -module Distribution.Simple.Command ( - - -- * Command interface - CommandUI(..), - commandShowOptions, - CommandParse(..), - commandParseArgs, - getNormalCommandDescriptions, - helpCommandUI, - - -- ** Constructing commands - ShowOrParseArgs(..), - usageDefault, - usageAlternatives, - mkCommandUI, - hiddenCommand, +module Distribution.Simple.Command + ( -- * Command interface + CommandUI (..) + , commandShowOptions + , CommandParse (..) + , commandParseArgs + , getNormalCommandDescriptions + , helpCommandUI - -- ** Associating actions with commands - Command, - commandAddAction, - noExtraFlags, + -- ** Constructing commands + , ShowOrParseArgs (..) + , usageDefault + , usageAlternatives + , mkCommandUI + , hiddenCommand - -- ** Building lists of commands - CommandType(..), - CommandSpec(..), - commandFromSpec, + -- ** Associating actions with commands + , Command + , commandAddAction + , noExtraFlags - -- ** Running commands - commandsRun, + -- ** Building lists of commands + , CommandType (..) + , CommandSpec (..) + , commandFromSpec --- * Option Fields - OptionField(..), Name, + -- ** Running commands + , commandsRun + , commandsRunWithFallback + , defaultCommandFallback --- ** Constructing Option Fields - option, multiOption, + -- * Option Fields + , OptionField (..) + , Name --- ** Liftings & Projections - liftOption, liftOptionL, + -- ** Constructing Option Fields + , option + , multiOption --- * Option Descriptions - OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + -- ** Liftings & Projections + , liftOption + , liftOptionL --- ** OptDescr 'smart' constructors - MkOptDescr, - reqArg, reqArg', optArg, optArg', noArg, - boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + -- * Option Descriptions + , OptDescr (..) + , fmapOptDescr + , Description + , SFlags + , LFlags + , OptFlags + , ArgPlaceHolder + -- ** OptDescr 'smart' constructors + , MkOptDescr + , reqArg + , reqArg' + , optArg + , optArg' + , optArgDef' + , noArg + , boolOpt + , boolOpt' + , choiceOpt + , choiceOptFromEnum ) where -import Prelude () import Distribution.Compat.Prelude hiding (get) +import Prelude () import qualified Data.Array as Array import qualified Data.List as List +import Distribution.Compat.Lens (ALens', (#~), (^#)) import qualified Distribution.GetOpt as GetOpt import Distribution.ReadE import Distribution.Simple.Utils -import Distribution.Compat.Lens (ALens', (^#), (#~)) - -data CommandUI flags = CommandUI { - -- | The name of the command as it would be entered on the command line. - -- For example @\"build\"@. - commandName :: String, - -- | A short, one line description of the command to use in help texts. - commandSynopsis :: String, - -- | A function that maps a program name to a usage summary for this - -- command. - commandUsage :: String -> String, - -- | Additional explanation of the command to use in help texts. - commandDescription :: Maybe (String -> String), - -- | Post-Usage notes and examples in help texts - commandNotes :: Maybe (String -> String), - -- | Initial \/ empty flags - commandDefaultFlags :: flags, - -- | All the Option fields for this command - commandOptions :: ShowOrParseArgs -> [OptionField flags] +data CommandUI flags = CommandUI + { commandName :: String + -- ^ The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + , commandSynopsis :: String + -- ^ A short, one line description of the command to use in help texts. + , commandUsage :: String -> String + -- ^ A function that maps a program name to a usage summary for this + -- command. + , commandDescription :: Maybe (String -> String) + -- ^ Additional explanation of the command to use in help texts. + , commandNotes :: Maybe (String -> String) + -- ^ Post-Usage notes and examples in help texts + , commandDefaultFlags :: flags + -- ^ Initial \/ empty flags + , commandOptions :: ShowOrParseArgs -> [OptionField flags] + -- ^ All the Option fields for this command } data ShowOrParseArgs = ShowArgs | ParseArgs -type Name = String +type Name = String type Description = String -- | We usually have a data type for storing configuration values, where @@ -107,481 +125,670 @@ -- the value either via command line flags or a configuration file. -- An individual OptionField models such a field, and we usually -- build a list of options associated to a configuration data type. -data OptionField a = OptionField { - optionName :: Name, - optionDescr :: [OptDescr a] } +data OptionField a = OptionField + { optionName :: Name + , optionDescr :: [OptDescr a] + } -- | An OptionField takes one or more OptDescrs, describing the command line -- interface for the field. -data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a -> [String]) - - | OptArg Description OptFlags ArgPlaceHolder - (ReadE (a->a)) (a->a) (a -> [Maybe String]) - - | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] +data OptDescr a + = ReqArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (a -> [String]) + | OptArg + Description + OptFlags + ArgPlaceHolder + (ReadE (a -> a)) + (String, a -> a) + (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)] + | BoolOpt + Description + OptFlags {-True-} + OptFlags {-False-} + (Bool -> a -> a) + (a -> Maybe Bool) - | BoolOpt Description OptFlags{-True-} OptFlags{-False-} - (Bool -> a -> a) (a-> Maybe Bool) +fmapOptDescr :: forall a b. (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +fmapOptDescr x u = \case + ReqArg d o p upd get -> ReqArg d o p (fmap m upd) (get . x) + OptArg d o p upd (str, g) get -> OptArg d o p (fmap m upd) (str, m g) (get . x) + ChoiceOpt opts -> ChoiceOpt $ fmap (\(d, o, upd, get) -> (d, o, m upd, get . x)) opts + BoolOpt d true false upd get -> BoolOpt d true false (\b -> m $ upd b) (get . x) + where + m :: (a -> a) -> (b -> b) + m upd_a b = u (upd_a $ x b) b -- | Short command line option strings -type SFlags = [Char] +type SFlags = [Char] + -- | Long command line option strings -type LFlags = [String] -type OptFlags = (SFlags,LFlags) -type ArgPlaceHolder = String +type LFlags = [String] +type OptFlags = (SFlags, LFlags) +type ArgPlaceHolder = String -- | Create an option taking a single OptDescr. -- No explicit Name is given for the Option, the name is the first LFlag given. -option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a - -> OptionField a -option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] -option _ _ _ _ _ _ = error $ "Distribution.command.option: " - ++ "An OptionField must have at least one LFlag" +-- +-- Example: @'option' sf lf d get set@ +-- * @sf@: Short option name, for example: @[\'d\']@. No hyphen permitted. +-- * @lf@: Long option name, for example: @["debug"]@. No hyphens permitted. +-- * @d@: Description of the option, shown to the user in help messages. +-- * @get@: Get the current value of the flag. +-- * @set@: Set the value of the flag. Gets the current value of the flag as a +-- parameter. +option + :: SFlags + -> LFlags + -> Description + -> get + -> set + -> MkOptDescr get set a + -> OptionField a +option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = + error $ + "Distribution.command.option: " + ++ "An OptionField must have at least one LFlag" -- | Create an option taking several OptDescrs. -- You will have to give the flags and description individually to the -- OptDescr constructor. -multiOption :: Name -> get -> set - -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially - -- applied to flags and description. - -> OptionField a +multiOption + :: Name + -> get + -> set + -> [get -> set -> OptDescr a] + -- ^ MkOptDescr constructors partially + -- applied to flags and description. + -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set - -> OptDescr a +type MkOptDescr get set a = + SFlags + -> LFlags + -> Description + -> get + -> set + -> OptDescr a -- | Create a string-valued command line interface. -reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +-- Usually called in the context of 'option' or 'multiOption'. +-- +-- Example: @'reqArg' ad mkflag showflag@ +-- +-- * @ad@: Placeholder shown to the user, e.g. @"FILES"@ if files are expected +-- parameters. +-- * @mkflag@: How to parse the argument into the option. +-- * @showflag@: If parsing goes wrong, display a useful error message to +-- the user. +reqArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set = - ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (showflag . get) + ReqArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (showflag . get) -- | Create a string-valued command line interface with a default value. -optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a -optArg ad mkflag def showflag sf lf d get set = - OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) - (\b -> set (get b `mappend` def) b) - (showflag . get) +optArg + :: Monoid b + => ArgPlaceHolder + -> ReadE b + -> (String, b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag (dv, mkDef) showflag sf lf d get set = + OptArg + d + (sf, lf) + ad + (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (dv, \b -> set (get b `mappend` mkDef) b) + (showflag . get) -- | (String -> a) variant of "reqArg" -reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' + :: Monoid b + => ArgPlaceHolder + -> (String -> b) + -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a reqArg' ad mkflag showflag = - reqArg ad (succeedReadE mkflag) showflag + reqArg ad (succeedReadE mkflag) showflag -- | (String -> a) variant of "optArg" -optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) - -> (b -> [Maybe String]) - -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' + :: Monoid b + => ArgPlaceHolder + -> (Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag = - optArg ad (succeedReadE (mkflag . Just)) def showflag - where def = mkflag Nothing + optArg ad (succeedReadE (mkflag . Just)) ("", mkflag Nothing) showflag -noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a -noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d +optArgDef' + :: Monoid b + => ArgPlaceHolder + -> (String, Maybe String -> b) + -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArgDef' ad (dv, mkflag) showflag = + optArg ad (succeedReadE (mkflag . Just)) (dv, mkflag Nothing) showflag -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt g s sfT sfF _sf _lf@(n:_) d get set = - BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) -boolOpt _ _ _ _ _ _ _ _ _ = error - "Distribution.Simple.Setup.boolOpt: unreachable" +noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags - -> MkOptDescr (a -> b) (b -> a -> a) a -boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) +boolOpt + :: (b -> Maybe Bool) + -> (Bool -> b) + -> SFlags + -> SFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n : _) d get set = + BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get) +boolOpt _ _ _ _ _ _ _ _ _ = + error + "Distribution.Simple.Setup.boolOpt: unreachable" +boolOpt' + :: (b -> Maybe Bool) + -> (Bool -> b) + -> OptFlags + -> OptFlags + -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get) + -- | create a Choice option -choiceOpt :: Eq b => [(b,OptFlags,Description)] - -> MkOptDescr (a -> b) (b -> a -> a) a -choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts - where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] +choiceOpt + :: Eq b + => [(b, OptFlags, Description)] + -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where + alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff] -- | create a Choice option out of an enumeration type. -- As long flags, the Show output is used. As short flags, the first character -- which does not conflict with a previous one is used. -choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => - MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum + :: (Bounded b, Enum b, Show b, Eq b) + => MkOptDescr (a -> b) (b -> a -> a) a choiceOptFromEnum _sf _lf d get = - choiceOpt [ (x, (sf, [map toLower $ show x]), d') - | (x, sf) <- sflags' - , let d' = d ++ show x] - _sf _lf d get - where sflags' = foldl f [] [firstOne..] - f prev x = let prevflags = concatMap snd prev in - prev ++ take 1 [(x, [toLower sf]) - | sf <- show x, isAlpha sf - , toLower sf `notElem` prevflags] - firstOne = minBound `asTypeOf` get undefined + choiceOpt + [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x + ] + _sf + _lf + d + get + where + sflags' = foldl f [] [firstOne ..] + f prev x = + let prevflags = concatMap snd prev + in prev + ++ take + 1 + [ (x, [toLower sf]) + | sf <- show x + , isAlpha sf + , toLower sf `notElem` prevflags + ] + firstOne = minBound `asTypeOf` get undefined -commandGetOpts :: ShowOrParseArgs -> CommandUI flags - -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts + :: ShowOrParseArgs + -> CommandUI flags + -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command = - concatMap viewAsGetOpt (commandOptions command showOrParse) + concatMap viewAsGetOpt (commandOptions command showOrParse) -viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)] viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa where - optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = - [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] - where set' = readEOrFail set - optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = - [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] - where set' Nothing = def - set' (Just txt) = readEOrFail set txt + optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d] + optDescrToGetOpt (OptArg d (cs, ss) arg_desc set (dv, def) _) = + [GetOpt.Option cs ss (GetOpt.OptArg dv set' arg_desc) d] + where + set' Nothing = Right def + set' (Just txt) = runReadE set txt optDescrToGetOpt (ChoiceOpt alts) = - [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] - optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ] - optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = - [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ] - optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = - [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) - , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts] + optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) = + [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d] + optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) = + [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d] + optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) + ] getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a = - [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] - + [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a] getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" - liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b liftOption get' set' opt = - opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt} -- | @since 3.4.0.0 liftOptionL :: ALens' b a -> OptionField a -> OptionField b liftOptionL l = liftOption (^# l) (l #~) - liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b liftOptDescr get' set' (ChoiceOpt opts) = - ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) - | (d, ff, set, get) <- opts] - -liftOptDescr get' set' (OptArg d ff ad set def get) = - OptArg d ff ad (liftSet get' set' `fmap` set) - (liftSet get' set' def) (get . get') - + ChoiceOpt + [ (d, ff, liftSet get' set' set, (get . get')) + | (d, ff, set, get) <- opts + ] +liftOptDescr get' set' (OptArg d ff ad set (dv, mkDef) get) = + OptArg + d + ff + ad + (liftSet get' set' `fmap` set) + (dv, liftSet get' set' mkDef) + (get . get') liftOptDescr get' set' (ReqArg d ff ad set get) = - ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') - + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') liftOptDescr get' set' (BoolOpt d ffT ffF set get) = - BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b liftSet get' set' set x = set' (set $ get' x) x -- | Show flags in the standard long option command line format commandShowOptions :: CommandUI flags -> flags -> [String] -commandShowOptions command v = concat - [ showOptDescr v od | o <- commandOptions command ParseArgs - , od <- optionDescr o] +commandShowOptions command v = + concat + [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o + ] where - maybePrefix [] = [] - maybePrefix (lOpt:_) = ["--" ++ lOpt] + maybePrefix [] = [] + maybePrefix (lOpt : _) = ["--" ++ lOpt] showOptDescr :: a -> OptDescr a -> [String] - showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled) - = case enabled x of - Nothing -> [] - Just True -> maybePrefix lfTs - Just False -> maybePrefix lfFs - showOptDescr x c@ChoiceOpt{} - = ["--" ++ val | val <- getCurrentChoice c x] - showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) - = [ "--"++lf++"="++flag - | flag <- showflag x ] - showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) - = [ case flag of - Just s -> "--"++lf++"="++s - Nothing -> "--"++lf - | flag <- showflag x ] - showOptDescr _ _ - = error "Distribution.Simple.Command.showOptDescr: unreachable" - + showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) = + case enabled x of + Nothing -> [] + Just True -> maybePrefix lfTs + Just False -> maybePrefix lfFs + showOptDescr x c@ChoiceOpt{} = + ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) = + [ "--" ++ lf ++ "=" ++ flag + | flag <- showflag x + ] + showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) = + [ case flag of + Just s -> "--" ++ lf ++ "=" ++ s + Nothing -> "--" ++ lf + | flag <- showflag x + ] + showOptDescr _ _ = + error "Distribution.Simple.Command.showOptDescr: unreachable" commandListOptions :: CommandUI flags -> [String] commandListOptions command = concatMap listOption $ addCommonFlags ShowArgs $ -- This is a slight hack, we don't want - -- "--list-options" showing up in the - -- list options output, so use ShowArgs + -- "--list-options" showing up in the + -- list options output, so use ShowArgs commandGetOpts ShowArgs command where listOption (GetOpt.Option shortNames longNames _ _) = - [ "-" ++ [name] | name <- shortNames ] - ++ [ "--" ++ name | name <- longNames ] + ["-" ++ [name] | name <- shortNames] + ++ ["--" ++ name | name <- longNames] -- | The help text for this command with descriptions of all the options. commandHelp :: CommandUI flags -> String -> String commandHelp command pname = - commandSynopsis command - ++ "\n\n" - ++ commandUsage command pname - ++ ( case commandDescription command of - Nothing -> "" - Just desc -> '\n': desc pname) - ++ "\n" - ++ ( if cname == "" - then "Global flags:" - else "Flags for " ++ cname ++ ":" ) - ++ ( GetOpt.usageInfo "" - . addCommonFlags ShowArgs - $ commandGetOpts ShowArgs command ) - ++ ( case commandNotes command of - Nothing -> "" - Just notes -> '\n': notes pname) - where cname = commandName command + commandSynopsis command + ++ "\n\n" + ++ commandUsage command pname + ++ ( case commandDescription command of + Nothing -> "" + Just desc -> '\n' : desc pname + ) + ++ "\n" + ++ ( if cname == "" + then "Global flags:" + else "Flags for " ++ cname ++ ":" + ) + ++ ( GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command + ) + ++ ( case commandNotes command of + Nothing -> "" + Just notes -> '\n' : notes pname + ) + where + cname = commandName command -- | Default "usage" documentation text for commands. usageDefault :: String -> String -> String usageDefault name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" - ++ "Flags for " ++ name ++ ":" + "Usage: " + ++ pname + ++ " " + ++ name + ++ " [FLAGS]\n\n" + ++ "Flags for " + ++ name + ++ ":" -- | Create "usage" documentation from a list of parameter -- configurations. usageAlternatives :: String -> [String] -> String -> String -usageAlternatives name strs pname = unlines - [ start ++ pname ++ " " ++ name ++ " " ++ s - | let starts = "Usage: " : repeat " or: " - , (start, s) <- zip starts strs - ] +usageAlternatives name strs pname = + unlines + [ start ++ pname ++ " " ++ name ++ " " ++ s + | let starts = "Usage: " : repeat " or: " + , (start, s) <- zip starts strs + ] -- | Make a Command from standard 'GetOpt' options. -mkCommandUI :: String -- ^ name - -> String -- ^ synopsis - -> [String] -- ^ usage alternatives - -> flags -- ^ initial\/empty flags - -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options - -> CommandUI flags -mkCommandUI name synopsis usages flags options = CommandUI - { commandName = name - , commandSynopsis = synopsis - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = usageAlternatives name usages - , commandDefaultFlags = flags - , commandOptions = options - } +mkCommandUI + :: String + -- ^ name + -> String + -- ^ synopsis + -> [String] + -- ^ usage alternatives + -> flags + -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) + -- ^ options + -> CommandUI flags +mkCommandUI name synopsis usages flags options = + CommandUI + { commandName = name + , commandSynopsis = synopsis + , commandDescription = Nothing + , commandNotes = Nothing + , commandUsage = usageAlternatives name usages + , commandDefaultFlags = flags + , commandOptions = options + } -- | Common flags that apply to every command data CommonFlag = HelpFlag | ListOptionsFlag commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] commonFlags showOrParseArgs = case showOrParseArgs of - ShowArgs -> [help] + ShowArgs -> [help] ParseArgs -> [help, list] - where - help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) - "Show this help text" + where + help = + GetOpt.Option + helpShortFlags + ["help"] + (GetOpt.NoArg HelpFlag) + "Show this help text" helpShortFlags = case showOrParseArgs of - ShowArgs -> ['h'] + ShowArgs -> ['h'] ParseArgs -> ['h', '?'] - list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) - "Print a list of command line flags" + list = + GetOpt.Option + [] + ["list-options"] + (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" -addCommonFlags :: ShowOrParseArgs - -> [GetOpt.OptDescr a] - -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags + :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] addCommonFlags showOrParseArgs options = - map (fmapOptDesc Left) (commonFlags showOrParseArgs) - ++ map (fmapOptDesc Right) options - where fmapOptDesc f (GetOpt.Option s l d m) = - GetOpt.Option s l (fmapArgDesc f d) m - fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) - fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d - fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + map (fmap Left) (commonFlags showOrParseArgs) + ++ map (fmap Right) options -- | Parse a bunch of command line arguments --- -commandParseArgs :: CommandUI flags - -> Bool -- ^ Is the command a global or subcommand? - -> [String] - -> CommandParse (flags -> flags, [String]) +commandParseArgs + :: CommandUI flags + -> Bool + -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) commandParseArgs command global args = - let options = addCommonFlags ParseArgs - $ commandGetOpts ParseArgs command - order | global = GetOpt.RequireOrder - | otherwise = GetOpt.Permute - in case GetOpt.getOpt' order options args of - (flags, _, _, _) - | any listFlag flags -> CommandList (commandListOptions command) - | any helpFlag flags -> CommandHelp (commandHelp command) - where listFlag (Left ListOptionsFlag) = True; listFlag _ = False - helpFlag (Left HelpFlag) = True; helpFlag _ = False - (flags, opts, opts', []) - | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') - | otherwise -> CommandErrors (unrecognised opts') - (_, _, _, errs) -> CommandErrors errs - - where -- Note: It is crucial to use reverse function composition here or to - -- reverse the flags here as we want to process the flags left to right - -- but data flow in function composition is right to left. - accum flags = foldr (flip (.)) id [ f | Right f <- flags ] - unrecognised opts = [ "unrecognized " - ++ "'" ++ (commandName command) ++ "'" - ++ " option `" ++ opt ++ "'\n" - | opt <- opts ] - -- For unrecognised global flags we put them in the position just after - -- the command, if there is one. This gives us a chance to parse them - -- as sub-command rather than global flags. - mix [] ys = ys - mix (x:xs) ys = x:ys++xs + let options = + addCommonFlags ParseArgs $ + commandGetOpts ParseArgs command + order + | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where + listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + where + -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function composition is right to left. + accum flags = foldr (flip (.)) id [f | Right f <- flags] + unrecognised opts = + [ "unrecognized " + ++ "'" + ++ (commandName command) + ++ "'" + ++ " option `" + ++ opt + ++ "'\n" + | opt <- opts + ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x : xs) ys = x : ys ++ xs -data CommandParse flags = CommandHelp (String -> String) - | CommandList [String] - | CommandErrors [String] - | CommandReadyToGo flags +data CommandParse flags + = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags instance Functor CommandParse where - fmap _ (CommandHelp help) = CommandHelp help - fmap _ (CommandList opts) = CommandList opts - fmap _ (CommandErrors errs) = CommandErrors errs + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) - data CommandType = NormalCommand | HiddenCommand -data Command action = - Command String String ([String] -> CommandParse action) CommandType +data Command action + = Command String String ([String] -> CommandParse action) CommandType -- | Mark command as hidden. Hidden commands don't show up in the 'progname -- help' or 'progname --help' output. hiddenCommand :: Command action -> Command action -hiddenCommand (Command name synopsys f _cmdType) = - Command name synopsys f HiddenCommand +hiddenCommand (Command name synopsis f _cmdType) = + Command name synopsis f HiddenCommand -commandAddAction :: CommandUI flags - -> (flags -> [String] -> action) - -> Command action +commandAddAction + :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action commandAddAction command action = - Command (commandName command) - (commandSynopsis command) - (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) - NormalCommand + Command + (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) . commandParseArgs command False) + NormalCommand + where + applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args - where applyDefaultArgs mkflags args = - let flags = mkflags (commandDefaultFlags command) - in action flags args +-- Print suggested command if edit distance is < 5 +badCommand :: [Command action] -> String -> CommandParse a +badCommand commands' cname = + case eDists of + [] -> CommandErrors [unErr] + (s : _) -> + CommandErrors + [ unErr + , "Maybe you meant `" ++ s ++ "`?\n" + ] + where + eDists = + map fst . List.sortBy (comparing snd) $ + [ (cname', dist) + | -- Note that this is not commandNames, so close suggestions will show + -- hidden commands + (Command cname' _ _ _) <- commands' + , let dist = editDistance cname' cname + , dist < 5 + ] + unErr = "unrecognised command: " ++ cname ++ " (try --help)" -commandsRun :: CommandUI a - -> [Command action] - -> [String] - -> CommandParse (a, CommandParse action) +commandsRun + :: CommandUI a + -> [Command action] + -> [String] + -> IO (CommandParse (a, CommandParse action)) commandsRun globalCommand commands args = - case commandParseArgs globalCommand True args of - CommandHelp help -> CommandHelp help - CommandList opts -> CommandList (opts ++ commandNames) - CommandErrors errs -> CommandErrors errs - CommandReadyToGo (mkflags, args') -> case args' of - ("help":cmdArgs) -> handleHelpCommand cmdArgs - (name:cmdArgs) -> case lookupCommand name of - [Command _ _ action _] - -> CommandReadyToGo (flags, action cmdArgs) - _ -> CommandReadyToGo (flags, badCommand name) - [] -> CommandReadyToGo (flags, noCommand) - where flags = mkflags (commandDefaultFlags globalCommand) + commandsRunWithFallback globalCommand commands defaultCommandFallback args - where - lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands' - , cname' == cname ] - noCommand = CommandErrors ["no command given (try --help)\n"] +defaultCommandFallback + :: [Command action] + -> String + -> [String] + -> IO (CommandParse action) +defaultCommandFallback commands' name _cmdArgs = pure $ badCommand commands' name - -- Print suggested command if edit distance is < 5 - badCommand :: String -> CommandParse a - badCommand cname = - case eDists of - [] -> CommandErrors [unErr] - (s:_) -> CommandErrors [ unErr - , "Maybe you meant `" ++ s ++ "`?\n"] +commandsRunWithFallback + :: CommandUI a + -> [Command action] + -> ([Command action] -> String -> [String] -> IO (CommandParse action)) + -> [String] + -> IO (CommandParse (a, CommandParse action)) +commandsRunWithFallback globalCommand commands defaultCommand args = + case commandParseArgs globalCommand True args of + CommandHelp help -> pure $ CommandHelp help + CommandList opts -> pure $ CommandList (opts ++ commandNames) + CommandErrors errs -> pure $ CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help" : cmdArgs) -> handleHelpCommand flags cmdArgs + (name : cmdArgs) -> case lookupCommand name of + [Command _ _ action _] -> + pure $ CommandReadyToGo (flags, action cmdArgs) + _ -> do + final_cmd <- defaultCommand commands' name cmdArgs + return $ CommandReadyToGo (flags, final_cmd) + [] -> pure $ CommandReadyToGo (flags, noCommand) where - eDists = map fst . List.sortBy (comparing snd) $ - [ (cname', dist) - | (Command cname' _ _ _) <- commands' - , let dist = editDistance cname' cname - , dist < 5 ] - unErr = "unrecognised command: " ++ cname ++ " (try --help)" + flags = mkflags (commandDefaultFlags globalCommand) + where + lookupCommand cname = + [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname + ] - commands' = commands ++ [commandAddAction helpCommandUI undefined] - commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ] + noCommand = CommandErrors ["no command given (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [name | (Command name _ _ NormalCommand) <- commands'] + -- A bit of a hack: support "prog help" as a synonym of "prog --help" -- furthermore, support "prog help command" as "prog command --help" - handleHelpCommand cmdArgs = + handleHelpCommand flags cmdArgs = case commandParseArgs helpCommandUI True cmdArgs of - CommandHelp help -> CommandHelp help - CommandList list -> CommandList (list ++ commandNames) - CommandErrors _ -> CommandHelp globalHelp - CommandReadyToGo (_,[]) -> CommandHelp globalHelp - CommandReadyToGo (_,(name:cmdArgs')) -> + CommandHelp help -> pure $ CommandHelp help + CommandList list -> pure $ CommandList (list ++ commandNames) + CommandErrors _ -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, []) -> pure $ CommandHelp globalHelp + CommandReadyToGo (_, (name : cmdArgs')) -> case lookupCommand name of [Command _ _ action _] -> - case action ("--help":cmdArgs') of - CommandHelp help -> CommandHelp help - CommandList _ -> CommandList [] - _ -> CommandHelp globalHelp - _ -> badCommand name - - where globalHelp = commandHelp globalCommand + case action ("--help" : cmdArgs') of + CommandHelp help -> pure $ CommandHelp help + CommandList _ -> pure $ CommandList [] + _ -> pure $ CommandHelp globalHelp + _ -> do + fall_back <- defaultCommand commands' name ("--help" : cmdArgs') + return $ CommandReadyToGo (flags, fall_back) + where + globalHelp = commandHelp globalCommand -- Levenshtein distance, from https://wiki.haskell.org/Edit_distance -- (Author: JeanPhilippeBernardy, Simple Permissive Licence) editDistance :: Eq a => [a] -> [a] -> Int -editDistance xs ys = table Array.! (m,n) +editDistance xs ys = table Array.! (m, n) where - (m,n) = (length xs, length ys) - x = Array.array (1,m) (zip [1..] xs) - y = Array.array (1,n) (zip [1..] ys) + (m, n) = (length xs, length ys) + x = Array.array (1, m) (zip [1 ..] xs) + y = Array.array (1, n) (zip [1 ..] ys) - table :: Array.Array (Int,Int) Int + table :: Array.Array (Int, Int) Int table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds] - bnds = ((0,0),(m,n)) + bnds = ((0, 0), (m, n)) - dist (0,j) = j - dist (i,0) = i - dist (i,j) = minimum - [ table Array.! (i-1,j) + 1 - , table Array.! (i,j-1) + 1 - , if x Array.! i == y Array.! j - then table Array.! (i-1,j-1) - else 1 + table Array.! (i-1,j-1) - ] + dist (0, j) = j + dist (i, 0) = i + dist (i, j) = + minimum + [ table Array.! (i - 1, j) + 1 + , table Array.! (i, j - 1) + 1 + , if x Array.! i == y Array.! j + then table Array.! (i - 1, j - 1) + else 1 + table Array.! (i - 1, j - 1) + ] -- | Utility function, many commands do not accept additional flags. This -- action fails with a helpful error message if the user supplies any extra. --- noExtraFlags :: [String] -> IO () noExtraFlags [] = return () noExtraFlags extraFlags = dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags ---TODO: eliminate this function and turn it into a variant on commandAddAction + +-- TODO: eliminate this function and turn it into a variant on commandAddAction -- instead like commandAddActionNoArgs that doesn't supply the [String] -- | Helper function for creating globalCommand description getNormalCommandDescriptions :: [Command action] -> [(String, String)] getNormalCommandDescriptions cmds = [ (name, description) - | Command name description _ NormalCommand <- cmds ] + | Command name description _ NormalCommand <- cmds + ] helpCommandUI :: CommandUI () helpCommandUI = - (mkCommandUI - "help" - "Help about commands." - ["[FLAGS]", "COMMAND [FLAGS]"] - () - (const [])) - { - commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " help help\n" - ++ " Oh, appararently you already know this.\n" - } + ( mkCommandUI + "help" + "Help about commands." + ["[FLAGS]", "COMMAND [FLAGS]"] + () + (const []) + ) + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " + ++ pname + ++ " help help\n" + ++ " Oh, apparently you already know this.\n" + } -- | wraps a @CommandUI@ together with a function that turns it into a @Command@. -- By hiding the type of flags for the UI allows construction of a list of all UIs at the diff --git a/src/Distribution/Simple/Compiler.hs b/src/Distribution/Simple/Compiler.hs --- a/src/Distribution/Simple/Compiler.hs +++ b/src/Distribution/Simple/Compiler.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveTraversable #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Compiler -- Copyright : Isaac Jones 2003-2004 @@ -20,87 +22,108 @@ -- only know about a single global package collection but GHC has a global and -- per-user one and it lets you create arbitrary other package databases. We do -- not yet fully support this latter feature. - -module Distribution.Simple.Compiler ( - -- * Haskell implementations - module Distribution.Compiler, - Compiler(..), - showCompilerId, showCompilerIdWithAbi, - compilerFlavor, compilerVersion, - compilerCompatFlavor, - compilerCompatVersion, - compilerInfo, +module Distribution.Simple.Compiler + ( -- * Haskell implementations + module Distribution.Compiler + , Compiler (..) + , showCompilerId + , showCompilerIdWithAbi + , compilerFlavor + , compilerVersion + , compilerCompatFlavor + , compilerCompatVersion + , compilerInfo - -- * Support for package databases - PackageDB(..), - PackageDBStack, - registrationPackageDB, - absolutePackageDBPaths, - absolutePackageDBPath, + -- * Support for package databases + , PackageDB + , PackageDBStack + , PackageDBCWD + , PackageDBStackCWD + , PackageDBX (..) + , PackageDBStackX + , PackageDBS + , PackageDBStackS + , registrationPackageDB + , absolutePackageDBPaths + , absolutePackageDBPath + , interpretPackageDB + , interpretPackageDBStack + , coercePackageDB + , coercePackageDBStack - -- * Support for optimisation levels - OptimisationLevel(..), - flagToOptimisationLevel, + -- * Support for optimisation levels + , OptimisationLevel (..) + , flagToOptimisationLevel - -- * Support for debug info levels - DebugInfoLevel(..), - flagToDebugInfoLevel, + -- * Support for debug info levels + , DebugInfoLevel (..) + , flagToDebugInfoLevel - -- * Support for language extensions - CompilerFlag, - languageToFlags, - unsupportedLanguages, - extensionsToFlags, - unsupportedExtensions, - parmakeSupported, - reexportedModulesSupported, - renamingPackageFlagsSupported, - unifiedIPIDRequired, - packageKeySupported, - unitIdSupported, - coverageSupported, - profilingSupported, - backpackSupported, - arResponseFilesSupported, - libraryDynDirSupported, - libraryVisibilitySupported, + -- * Support for language extensions + , CompilerFlag + , languageToFlags + , unsupportedLanguages + , extensionsToFlags + , unsupportedExtensions + , parmakeSupported + , reexportedModulesSupported + , renamingPackageFlagsSupported + , unifiedIPIDRequired + , packageKeySupported + , unitIdSupported + , coverageSupported + , profilingSupported + , profilingDynamicSupported + , profilingDynamicSupportedOrUnknown + , profilingVanillaSupported + , profilingVanillaSupportedOrUnknown + , dynamicSupported + , backpackSupported + , arResponseFilesSupported + , arDashLSupported + , libraryDynDirSupported + , libraryVisibilitySupported + , jsemSupported + , reexportedAsSupported - -- * Support for profiling detail levels - ProfDetailLevel(..), - knownProfDetailLevels, - flagToProfDetailLevel, - showProfDetailLevel, + -- * Support for profiling detail levels + , ProfDetailLevel (..) + , knownProfDetailLevels + , flagToProfDetailLevel + , showProfDetailLevel ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Pretty +import Prelude () import Distribution.Compiler +import Distribution.Simple.Utils +import Distribution.Utils.Path import Distribution.Version + import Language.Haskell.Extension -import Distribution.Simple.Utils import qualified Data.Map as Map (lookup) import System.Directory (canonicalizePath) -data Compiler = Compiler { - compilerId :: CompilerId, - -- ^ Compiler flavour and version. - compilerAbiTag :: AbiTag, - -- ^ Tag for distinguishing incompatible ABI's on the same - -- architecture/os. - compilerCompat :: [CompilerId], - -- ^ Other implementations that this compiler claims to be - -- compatible with. - compilerLanguages :: [(Language, CompilerFlag)], - -- ^ Supported language standards. - compilerExtensions :: [(Extension, Maybe CompilerFlag)], - -- ^ Supported extensions. - compilerProperties :: Map String String - -- ^ A key-value map for properties not covered by the above fields. - } - deriving (Eq, Generic, Typeable, Show, Read) +data Compiler = Compiler + { compilerId :: CompilerId + -- ^ Compiler flavour and version. + , compilerAbiTag :: AbiTag + -- ^ Tag for distinguishing incompatible ABI's on the same + -- architecture/os. + , compilerCompat :: [CompilerId] + -- ^ Other implementations that this compiler claims to be + -- compatible with. + , compilerLanguages :: [(Language, CompilerFlag)] + -- ^ Supported language standards. + , compilerExtensions :: [(Extension, Maybe CompilerFlag)] + -- ^ Supported extensions. + , compilerProperties :: Map String String + -- ^ A key-value map for properties not covered by the above fields. + } + deriving (Eq, Generic, Show, Read) instance Binary Compiler instance Structured Compiler @@ -110,30 +133,27 @@ showCompilerIdWithAbi :: Compiler -> String showCompilerIdWithAbi comp = - prettyShow (compilerId comp) ++ - case compilerAbiTag comp of - NoAbiTag -> [] - AbiTag xs -> '-':xs + prettyShow (compilerId comp) + ++ case compilerAbiTag comp of + NoAbiTag -> [] + AbiTag xs -> '-' : xs -compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor :: Compiler -> CompilerFlavor compilerFlavor = (\(CompilerId f _) -> f) . compilerId compilerVersion :: Compiler -> Version compilerVersion = (\(CompilerId _ v) -> v) . compilerId - -- | Is this compiler compatible with the compiler flavour we're interested in? -- -- For example this checks if the compiler is actually GHC or is another -- compiler that claims to be compatible with some version of GHC, e.g. GHCJS. -- -- > if compilerCompatFlavor GHC compiler then ... else ... --- compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool compilerCompatFlavor flavor comp = - flavor == compilerFlavor comp - || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ] - + flavor == compilerFlavor comp + || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp] -- | Is this compiler compatible with the compiler flavour we're interested in, -- and if so what version does it claim to be compatible with. @@ -144,38 +164,44 @@ -- > case compilerCompatVersion GHC compiler of -- > Just (Version (7:_)) -> ... -- > _ -> ... --- compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version compilerCompatVersion flavor comp | compilerFlavor comp == flavor = Just (compilerVersion comp) - | otherwise = - listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ] + | otherwise = + listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor] compilerInfo :: Compiler -> CompilerInfo -compilerInfo c = CompilerInfo (compilerId c) - (compilerAbiTag c) - (Just . compilerCompat $ c) - (Just . map fst . compilerLanguages $ c) - (Just . map fst . compilerExtensions $ c) +compilerInfo c = + CompilerInfo + (compilerId c) + (compilerAbiTag c) + (Just . compilerCompat $ c) + (Just . map fst . compilerLanguages $ c) + (Just . map fst . compilerExtensions $ c) -- ------------------------------------------------------------ + -- * Package databases + -- ------------------------------------------------------------ --- |Some compilers have a notion of a database of available packages. --- For some there is just one global db of packages, other compilers --- support a per-user or an arbitrary db specified at some location in --- the file system. This can be used to build isloated environments of --- packages, for example to build a collection of related packages --- without installing them globally. +-- | Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isolated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. -- -data PackageDB = GlobalPackageDB - | UserPackageDB - | SpecificPackageDB FilePath - deriving (Eq, Generic, Ord, Show, Read, Typeable) +-- Abstracted over +data PackageDBX fp + = GlobalPackageDB + | UserPackageDB + | -- | NB: the path might be relative or it might be absolute + SpecificPackageDB fp + deriving (Eq, Generic, Ord, Show, Read, Functor, Foldable, Traversable) -instance Binary PackageDB -instance Structured PackageDB +instance Binary fp => Binary (PackageDBX fp) +instance Structured fp => Structured (PackageDBX fp) -- | We typically get packages from several databases, and stack them -- together. This type lets us be explicit about that stacking. For example @@ -192,114 +218,165 @@ -- we can use several custom package dbs and the user package db together. -- -- When it comes to writing, the top most (last) package is used. --- -type PackageDBStack = [PackageDB] +type PackageDBStackX from = [PackageDBX from] +type PackageDB = PackageDBX (SymbolicPath Pkg (Dir PkgDB)) +type PackageDBStack = PackageDBStackX (SymbolicPath Pkg (Dir PkgDB)) + +type PackageDBS from = PackageDBX (SymbolicPath from (Dir PkgDB)) +type PackageDBStackS from = PackageDBStackX (SymbolicPath from (Dir PkgDB)) + +type PackageDBCWD = PackageDBX FilePath +type PackageDBStackCWD = PackageDBStackX FilePath + -- | Return the package that we should register into. This is the package db at -- the top of the stack. --- -registrationPackageDB :: PackageDBStack -> PackageDB -registrationPackageDB dbs = case safeLast dbs of +registrationPackageDB :: PackageDBStackX from -> PackageDBX from +registrationPackageDB dbs = case safeLast dbs of Nothing -> error "internal error: empty package db set" - Just p -> p + Just p -> p -- | Make package paths absolute +absolutePackageDBPaths + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> IO PackageDBStack +absolutePackageDBPaths mbWorkDir = traverse $ absolutePackageDBPath mbWorkDir +absolutePackageDBPath + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> IO PackageDB +absolutePackageDBPath _ GlobalPackageDB = return GlobalPackageDB +absolutePackageDBPath _ UserPackageDB = return UserPackageDB +absolutePackageDBPath mbWorkDir (SpecificPackageDB db) = do + let db' = + case symbolicPathRelative_maybe db of + Nothing -> getSymbolicPath db + Just rel_path -> interpretSymbolicPath mbWorkDir rel_path + SpecificPackageDB . makeSymbolicPath <$> canonicalizePath db' -absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack -absolutePackageDBPaths = traverse absolutePackageDBPath +interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD +interpretPackageDB _ GlobalPackageDB = GlobalPackageDB +interpretPackageDB _ UserPackageDB = UserPackageDB +interpretPackageDB mbWorkDir (SpecificPackageDB db) = + SpecificPackageDB (interpretSymbolicPath mbWorkDir db) -absolutePackageDBPath :: PackageDB -> IO PackageDB -absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB -absolutePackageDBPath UserPackageDB = return UserPackageDB -absolutePackageDBPath (SpecificPackageDB db) = - SpecificPackageDB `liftM` canonicalizePath db +interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD +interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir) +-- | Transform a package db using a FilePath into one using symbolic paths. +coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB)) +coercePackageDB GlobalPackageDB = GlobalPackageDB +coercePackageDB UserPackageDB = UserPackageDB +coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db) + +coercePackageDBStack + :: [PackageDBCWD] + -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))] +coercePackageDBStack = map coercePackageDB + -- ------------------------------------------------------------ + -- * Optimisation levels + -- ------------------------------------------------------------ -- | Some compilers support optimising. Some have different levels. -- For compilers that do not the level is just capped to the level -- they do support. --- -data OptimisationLevel = NoOptimisation - | NormalOptimisation - | MaximumOptimisation - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data OptimisationLevel + = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary OptimisationLevel instance Structured OptimisationLevel flagToOptimisationLevel :: Maybe String -> OptimisationLevel -flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel Nothing = NormalOptimisation flagToOptimisationLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: OptimisationLevel) - && i <= fromEnum (maxBound :: OptimisationLevel) - -> toEnum i - | otherwise -> error $ "Bad optimisation level: " ++ show i - ++ ". Valid values are 0..2" - _ -> error $ "Can't parse optimisation level " ++ s + && i <= fromEnum (maxBound :: OptimisationLevel) -> + toEnum i + | otherwise -> + error $ + "Bad optimisation level: " + ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s -- ------------------------------------------------------------ + -- * Debug info levels + -- ------------------------------------------------------------ -- | Some compilers support emitting debug info. Some have different -- levels. For compilers that do not the level is just capped to the -- level they do support. --- -data DebugInfoLevel = NoDebugInfo - | MinimalDebugInfo - | NormalDebugInfo - | MaximalDebugInfo - deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable) +data DebugInfoLevel + = NoDebugInfo + | MinimalDebugInfo + | NormalDebugInfo + | MaximalDebugInfo + deriving (Bounded, Enum, Eq, Generic, Read, Show) instance Binary DebugInfoLevel instance Structured DebugInfoLevel flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel -flagToDebugInfoLevel Nothing = NormalDebugInfo +flagToDebugInfoLevel Nothing = NormalDebugInfo flagToDebugInfoLevel (Just s) = case reads s of [(i, "")] | i >= fromEnum (minBound :: DebugInfoLevel) - && i <= fromEnum (maxBound :: DebugInfoLevel) - -> toEnum i - | otherwise -> error $ "Bad debug info level: " ++ show i - ++ ". Valid values are 0..3" - _ -> error $ "Can't parse debug info level " ++ s + && i <= fromEnum (maxBound :: DebugInfoLevel) -> + toEnum i + | otherwise -> + error $ + "Bad debug info level: " + ++ show i + ++ ". Valid values are 0..3" + _ -> error $ "Can't parse debug info level " ++ s -- ------------------------------------------------------------ + -- * Languages and Extensions + -- ------------------------------------------------------------ unsupportedLanguages :: Compiler -> [Language] -> [Language] unsupportedLanguages comp langs = - [ lang | lang <- langs - , isNothing (languageToFlag comp lang) ] + [ lang | lang <- langs, isNothing (languageToFlag comp lang) + ] languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag] -languageToFlags comp = filter (not . null) - . catMaybes . map (languageToFlag comp) - . maybe [Haskell98] (\x->[x]) +languageToFlags comp = + filter (not . null) + . catMaybes + . map (languageToFlag comp) + . maybe [Haskell98] (\x -> [x]) languageToFlag :: Compiler -> Language -> Maybe CompilerFlag languageToFlag comp ext = lookup ext (compilerLanguages comp) - --- |For the given compiler, return the extensions it does not support. +-- | For the given compiler, return the extensions it does not support. unsupportedExtensions :: Compiler -> [Extension] -> [Extension] unsupportedExtensions comp exts = - [ ext | ext <- exts - , isNothing (extensionToFlag' comp ext) ] + [ ext | ext <- exts, isNothing (extensionToFlag' comp ext) + ] type CompilerFlag = String --- |For the given compiler, return the flags for the supported extensions. +-- | For the given compiler, return the flags for the supported extensions. extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag] -extensionsToFlags comp = nub . filter (not . null) - . catMaybes . map (extensionToFlag comp) +extensionsToFlags comp = + nub + . filter (not . null) + . catMaybes + . map (extensionToFlag comp) -- | Looks up the flag for a given extension, for a given compiler. -- Ignores the subtlety of extensions which lack associated flags. @@ -328,8 +405,9 @@ -- | Does this compiler support thinning/renaming on package flags? renamingPackageFlagsSupported :: Compiler -> Bool -renamingPackageFlagsSupported = ghcSupported - "Support thinning and renaming package flags" +renamingPackageFlagsSupported = + ghcSupported + "Support thinning and renaming package flags" -- | Does this compiler have unified IPIDs (so no package keys) unifiedIPIDRequired :: Compiler -> Bool @@ -347,63 +425,134 @@ backpackSupported :: Compiler -> Bool backpackSupported = ghcSupported "Support Backpack" +-- | Does this compiler support the -jsem option? +jsemSupported :: Compiler -> Bool +jsemSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 7] + _ -> False + where + v = compilerVersion comp + +-- | Does the compiler support the -reexported-modules "A as B" syntax +reexportedAsSupported :: Compiler -> Bool +reexportedAsSupported comp = case compilerFlavor comp of + GHC -> v >= mkVersion [9, 12] + _ -> False + where + v = compilerVersion comp + -- | Does this compiler support a package database entry with: -- "dynamic-library-dirs"? libraryDynDirSupported :: Compiler -> Bool libraryDynDirSupported comp = case compilerFlavor comp of GHC -> - -- Not just v >= mkVersion [8,0,1,20161022], as there - -- are many GHC 8.1 nightlies which don't support this. - ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) || - v >= mkVersion [8,1,20161021]) - _ -> False - where - v = compilerVersion comp + -- Not just v >= mkVersion [8,0,1,20161022], as there + -- are many GHC 8.1 nightlies which don't support this. + ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1]) + || v >= mkVersion [8, 1, 20161021] + ) + _ -> False + where + v = compilerVersion comp -- | Does this compiler's "ar" command supports response file -- arguments (i.e. @file-style arguments). arResponseFilesSupported :: Compiler -> Bool arResponseFilesSupported = ghcSupported "ar supports at file" +-- | Does this compiler's "ar" command support llvm-ar's -L flag, +-- which compels the archiver to add an input archive's members +-- rather than adding the archive itself. +arDashLSupported :: Compiler -> Bool +arDashLSupported = ghcSupported "ar supports -L" + -- | Does this compiler support Haskell program coverage? coverageSupported :: Compiler -> Bool coverageSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False -- | Does this compiler support profiling? profilingSupported :: Compiler -> Bool profilingSupported comp = case compilerFlavor comp of - GHC -> True + GHC -> True GHCJS -> True - _ -> False + _ -> False +-- | Returns Just if we can certainly determine whether a way is supported +-- if we don't know, return Nothing +waySupported :: String -> Compiler -> Maybe Bool +waySupported way comp = + case compilerFlavor comp of + GHC -> + -- Information about compiler ways is only accurately reported after + -- 9.10.1. Which is useful as this is before profiling dynamic support + -- was introduced. (See GHC #24881) + if compilerVersion comp >= mkVersion [9, 10, 1] + then case Map.lookup "RTS ways" (compilerProperties comp) of + Just ways -> Just (way `elem` words ways) + Nothing -> Just False + else Nothing + _ -> Nothing + +-- | Either profiling is definitely supported or we don't know (so assume +-- it is) +profilingVanillaSupportedOrUnknown :: Compiler -> Bool +profilingVanillaSupportedOrUnknown comp = profilingVanillaSupported comp `elem` [Just True, Nothing] + +-- | Is the compiler distributed with profiling libraries +profilingVanillaSupported :: Compiler -> Maybe Bool +profilingVanillaSupported comp = waySupported "p" comp + +-- | Is the compiler distributed with profiling dynamic libraries +profilingDynamicSupported :: Compiler -> Maybe Bool +profilingDynamicSupported comp + | GHC <- compilerFlavor comp + , -- Certainly not before 9.11, as prof+dyn was not implemented yet. + compilerVersion comp <= mkVersion [9, 11, 0] = + Just False + | otherwise = + waySupported "p_dyn" comp + +-- | Either profiling dynamic is definitely supported or we don't know (so assume +-- it is) +profilingDynamicSupportedOrUnknown :: Compiler -> Bool +profilingDynamicSupportedOrUnknown comp = + profilingDynamicSupported comp `elem` [Just True, Nothing] + +-- | Is the compiler distributed with dynamic libraries +dynamicSupported :: Compiler -> Maybe Bool +dynamicSupported comp = waySupported "dyn" comp + -- | Does this compiler support a package database entry with: -- "visibility"? libraryVisibilitySupported :: Compiler -> Bool libraryVisibilitySupported comp = case compilerFlavor comp of - GHC -> v >= mkVersion [8,8] - _ -> False - where - v = compilerVersion comp + GHC -> v >= mkVersion [8, 8] + _ -> False + where + v = compilerVersion comp -- | Utility function for GHC only features ghcSupported :: String -> Compiler -> Bool ghcSupported key comp = case compilerFlavor comp of - GHC -> checkProp + GHC -> checkProp GHCJS -> checkProp - _ -> False - where checkProp = - case Map.lookup key (compilerProperties comp) of - Just "YES" -> True - _ -> False + _ -> False + where + checkProp = + case Map.lookup key (compilerProperties comp) of + Just "YES" -> True + _ -> False -- ------------------------------------------------------------ + -- * Profiling detail level + -- ------------------------------------------------------------ -- | Some compilers (notably GHC) support profiling and can instrument @@ -412,42 +561,47 @@ -- For compilers that do not support this notion or the particular detail -- levels, this is either ignored or just capped to some similar level -- they do support. --- -data ProfDetailLevel = ProfDetailNone - | ProfDetailDefault - | ProfDetailExportedFunctions - | ProfDetailToplevelFunctions - | ProfDetailAllFunctions - | ProfDetailOther String - deriving (Eq, Generic, Read, Show, Typeable) +data ProfDetailLevel + = ProfDetailNone + | ProfDetailDefault + | ProfDetailExportedFunctions + | ProfDetailToplevelFunctions + | ProfDetailAllFunctions + | ProfDetailTopLate + | ProfDetailOther String + deriving (Eq, Generic, Read, Show) instance Binary ProfDetailLevel instance Structured ProfDetailLevel flagToProfDetailLevel :: String -> ProfDetailLevel flagToProfDetailLevel "" = ProfDetailDefault -flagToProfDetailLevel s = - case lookup (lowercase s) - [ (name, value) - | (primary, aliases, value) <- knownProfDetailLevels - , name <- primary : aliases ] - of Just value -> value - Nothing -> ProfDetailOther s +flagToProfDetailLevel s = + case lookup + (lowercase s) + [ (name, value) + | (primary, aliases, value) <- knownProfDetailLevels + , name <- primary : aliases + ] of + Just value -> value + Nothing -> ProfDetailOther s knownProfDetailLevels :: [(String, [String], ProfDetailLevel)] knownProfDetailLevels = - [ ("default", [], ProfDetailDefault) - , ("none", [], ProfDetailNone) - , ("exported-functions", ["exported"], ProfDetailExportedFunctions) + [ ("default", [], ProfDetailDefault) + , ("none", [], ProfDetailNone) + , ("exported-functions", ["exported"], ProfDetailExportedFunctions) , ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions) - , ("all-functions", ["all"], ProfDetailAllFunctions) + , ("all-functions", ["all"], ProfDetailAllFunctions) + , ("late-toplevel", ["late"], ProfDetailTopLate) ] showProfDetailLevel :: ProfDetailLevel -> String showProfDetailLevel dl = case dl of - ProfDetailNone -> "none" - ProfDetailDefault -> "default" - ProfDetailExportedFunctions -> "exported-functions" - ProfDetailToplevelFunctions -> "toplevel-functions" - ProfDetailAllFunctions -> "all-functions" - ProfDetailOther other -> other + ProfDetailNone -> "none" + ProfDetailDefault -> "default" + ProfDetailExportedFunctions -> "exported-functions" + ProfDetailToplevelFunctions -> "toplevel-functions" + ProfDetailAllFunctions -> "all-functions" + ProfDetailTopLate -> "late-toplevel" + ProfDetailOther other -> other diff --git a/src/Distribution/Simple/Configure.hs b/src/Distribution/Simple/Configure.hs --- a/src/Distribution/Simple/Configure.hs +++ b/src/Distribution/Simple/Configure.hs @@ -1,2085 +1,2978 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Configure --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This deals with the /configure/ phase. It provides the 'configure' action --- which is given the package description and configure flags. It then tries --- to: configure the compiler; resolves any conditionals in the package --- description; resolve the package dependencies; check if all the extensions --- used by this package are supported by the compiler; check that all the build --- tools are available (including version checks if appropriate); checks for --- any required @pkg-config@ packages (updating the 'BuildInfo' with the --- results) --- --- Then based on all this it saves the info in the 'LocalBuildInfo' and writes --- it out to the @dist\/setup-config@ file. It also displays various details to --- the user, the amount of information displayed depending on the verbosity --- level. - -module Distribution.Simple.Configure - ( configure - , writePersistBuildConfig - , getConfigStateFile - , getPersistBuildConfig - , checkPersistBuildConfigOutdated - , tryGetPersistBuildConfig - , maybeGetPersistBuildConfig - , findDistPref, findDistPrefOrDefault - , getInternalLibraries - , computeComponentId - , computeCompatPackageKey - , localBuildInfoFile - , getInstalledPackages - , getInstalledPackagesMonitorFiles - , getPackageDBContents - , configCompilerEx, configCompilerAuxEx - , computeEffectiveProfiling - , ccLdOptionsBuildInfo - , checkForeignDeps - , interpretPackageDbFlags - , ConfigStateFileError(..) - , tryGetConfigStateFile - , platformDefines, - ) where - -import qualified Prelude as Unsafe (tail) -import Distribution.Compat.Prelude - -import Distribution.Compiler -import Distribution.Types.IncludeRenaming -import Distribution.Utils.NubList -import Distribution.Simple.Compiler -import Distribution.Simple.PreProcess -import Distribution.Package -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import Distribution.PackageDescription -import Distribution.PackageDescription.PrettyPrint -import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Simple.BuildToolDepends -import Distribution.Simple.Program -import Distribution.Simple.Setup as Setup -import Distribution.Simple.BuildTarget -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.PackageVersionConstraint -import Distribution.Types.LocalBuildInfo -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.GivenComponent -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Version -import Distribution.Verbosity -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Stack -import Distribution.Backpack.Configure -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack.PreExistingComponent -import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) -import Distribution.Backpack.Id -import Distribution.Utils.LogProgress - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite - -import Control.Exception - ( try ) -import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode ) -import Distribution.Compat.Directory ( listDirectory ) -import Data.ByteString.Lazy ( ByteString ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.List - ( (\\), inits, stripPrefix, intersect, dropWhileEnd ) -import qualified Data.Map as Map -import System.Directory - ( canonicalizePath, createDirectoryIfMissing, doesFileExist - , getTemporaryDirectory, removeFile) -import System.FilePath - ( (), isAbsolute, takeDirectory ) -import Distribution.Compat.Directory - ( doesPathExist ) -import qualified System.Info - ( compilerName, compilerVersion ) -import System.IO - ( hPutStrLn, hClose ) -import Distribution.Pretty - ( pretty, defaultStyle, prettyShow ) -import Distribution.Parsec - ( simpleParsec ) -import Text.PrettyPrint - ( Doc, ($+$), char, comma, hsep, nest - , punctuate, quotes, render, renderStyle, sep, text ) -import Distribution.Compat.Environment ( lookupEnv ) - -import qualified Data.Set as Set -import qualified Distribution.Compat.NonEmptySet as NES - - -type UseExternalInternalDeps = Bool - --- | The errors that can be thrown when reading the @setup-config@ file. -data ConfigStateFileError - = ConfigStateFileNoHeader -- ^ No header found. - | ConfigStateFileBadHeader -- ^ Incorrect header. - | ConfigStateFileNoParse -- ^ Cannot parse file contents. - | ConfigStateFileMissing -- ^ No file! - | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier - (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version. - deriving (Typeable) - --- | Format a 'ConfigStateFileError' as a user-facing error message. -dispConfigStateFileError :: ConfigStateFileError -> Doc -dispConfigStateFileError ConfigStateFileNoHeader = - text "Saved package config file header is missing." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileBadHeader = - text "Saved package config file header is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileNoParse = - text "Saved package config file is corrupt." - <+> text "Re-run the 'configure' command." -dispConfigStateFileError ConfigStateFileMissing = - text "Run the 'configure' command first." -dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = - text "Saved package config file is outdated:" - $+$ badCabal $+$ badCompiler - $+$ text "Re-run the 'configure' command." - where - badCabal = - text "• the Cabal version changed from" - <+> pretty oldCabal <+> "to" <+> pretty currentCabalId - badCompiler - | oldCompiler == currentCompilerId = mempty - | otherwise = - text "• the compiler changed from" - <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId - -instance Show ConfigStateFileError where - show = renderStyle defaultStyle . dispConfigStateFileError - -instance Exception ConfigStateFileError - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO LocalBuildInfo -getConfigStateFile filename = do - exists <- doesFileExist filename - unless exists $ throwIO ConfigStateFileMissing - -- Read the config file into a strict ByteString to avoid problems with - -- lazy I/O, then convert to lazy because the binary package needs that. - contents <- BS.readFile filename - let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents]) - - (cabalId, compId) <- parseHeader header - - let getStoredValue = do - result <- structuredDecodeOrFailIO (BLC8.tail body) - case result of - Left _ -> throwIO ConfigStateFileNoParse - Right x -> return x - deferErrorIfBadVersion act - | cabalId /= currentCabalId = do - eResult <- try act - throwIO $ ConfigStateFileBadVersion cabalId compId eResult - | otherwise = act - deferErrorIfBadVersion getStoredValue - where - _ = callStack -- TODO: attach call stack to exception - --- | Read the 'localBuildInfoFile', returning either an error or the local build --- info. -tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetConfigStateFile = try . getConfigStateFile - --- | Try to read the 'localBuildInfoFile'. -tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Either ConfigStateFileError LocalBuildInfo) -tryGetPersistBuildConfig = try . getPersistBuildConfig - --- | Read the 'localBuildInfoFile'. Throw an exception if the file is --- missing, if the file cannot be read, or if the file was created by an older --- version of Cabal. -getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO LocalBuildInfo -getPersistBuildConfig = getConfigStateFile . localBuildInfoFile - --- | Try to read the 'localBuildInfoFile'. -maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> IO (Maybe LocalBuildInfo) -maybeGetPersistBuildConfig = - liftM (either (const Nothing) Just) . tryGetPersistBuildConfig - --- | After running configure, output the 'LocalBuildInfo' to the --- 'localBuildInfoFile'. -writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path. - -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write. - -> IO () -writePersistBuildConfig distPref lbi = do - createDirectoryIfMissing False distPref - writeFileAtomic (localBuildInfoFile distPref) $ - BLC8.unlines [showHeader pkgId, structuredEncode lbi] - where - pkgId = localPackage lbi - --- | Identifier of the current Cabal package. -currentCabalId :: PackageIdentifier -currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion - --- | Identifier of the current compiler package. -currentCompilerId :: PackageIdentifier -currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName) - (mkVersion' System.Info.compilerVersion) - --- | Parse the @setup-config@ file header, returning the package identifiers --- for Cabal and the compiler. -parseHeader :: ByteString -- ^ The file contents. - -> IO (PackageIdentifier, PackageIdentifier) -parseHeader header = case BLC8.words header of - ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId, - "using", compId] -> - maybe (throwIO ConfigStateFileBadHeader) return $ do - _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier - cabalId' <- simpleParsec (BLC8.unpack cabalId) - compId' <- simpleParsec (BLC8.unpack compId) - return (cabalId', compId') - _ -> throwIO ConfigStateFileNoHeader - --- | Generate the @setup-config@ file header. -showHeader :: PackageIdentifier -- ^ The processed package. - -> ByteString -showHeader pkgId = BLC8.unwords - [ "Saved", "package", "config", "for" - , toUTF8LBS $ prettyShow pkgId - , "written", "by" - , BLC8.pack $ prettyShow currentCabalId - , "using" - , BLC8.pack $ prettyShow currentCompilerId - ] - --- | Check that localBuildInfoFile is up-to-date with respect to the --- .cabal file. -checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool -checkPersistBuildConfigOutdated distPref pkg_descr_file = - pkg_descr_file `moreRecentFile` localBuildInfoFile distPref - --- | Get the path of @dist\/setup-config@. -localBuildInfoFile :: FilePath -- ^ The @dist@ directory path. - -> FilePath -localBuildInfoFile distPref = distPref "setup-config" - --- ----------------------------------------------------------------------------- --- * Configuration --- ----------------------------------------------------------------------------- - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or the default prefix. -findDistPref :: FilePath -- ^ default \"dist\" prefix - -> Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath -findDistPref defDistPref overrideDistPref = do - envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") - return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) - where - parseEnvDistPref env = - case env of - Just distPref | not (null distPref) -> toFlag distPref - _ -> NoFlag - --- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken --- from (in order of highest to lowest preference) the override prefix, the --- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call --- this function to resolve a @*DistPref@ flag whenever it is not known to be --- set. (The @*DistPref@ flags are always set to a definite value before --- invoking 'UserHooks'.) -findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix - -> IO FilePath -findDistPrefOrDefault = findDistPref defaultDistPref - --- |Perform the \"@.\/setup configure@\" action. --- Returns the @.setup-config@ file. -configure :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo -configure (pkg_descr0, pbi) cfg = do - -- Determine the component we are configuring, if a user specified - -- one on the command line. We use a fake, flattened version of - -- the package since at this point, we're not really sure what - -- components we *can* configure. @Nothing@ means that we should - -- configure everything (the old behavior). - (mb_cname :: Maybe ComponentName) <- do - let flat_pkg_descr = flattenPackageDescription pkg_descr0 - targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg) - -- TODO: bleat if you use the module/file syntax - let targets' = [ cname | BuildTargetComponent cname <- targets ] - case targets' of - _ | null (configArgs cfg) -> return Nothing - [cname] -> return (Just cname) - [] -> die' verbosity "No valid component targets found" - _ -> die' verbosity - "Can only configure either single component or all of them" - - let use_external_internal_deps = isJust mb_cname - case mb_cname of - Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0) - Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0) - cname (Just (configInstantiateWith cfg)) - - -- configCID is only valid for per-component configure - when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ - die' verbosity "--cid is only supported for per-component configure" - - checkDeprecatedFlags verbosity cfg - checkExactConfiguration verbosity pkg_descr0 cfg - - -- Where to build the package - let buildDir :: FilePath -- e.g. dist/build - -- fromFlag OK due to Distribution.Simple calling - -- findDistPrefOrDefault to fill it in - buildDir = fromFlag (configDistPref cfg) "build" - createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir - - -- What package database(s) to use - let packageDbs :: PackageDBStack - packageDbs - = interpretPackageDbFlags - (fromFlag (configUserInstall cfg)) - (configPackageDBs cfg) - - -- comp: the compiler we're building with - -- compPlatform: the platform we're building for - -- programDb: location and args of all programs we're - -- building with - (comp :: Compiler, - compPlatform :: Platform, - programDb :: ProgramDb) - <- configCompilerEx - (flagToMaybe (configHcFlavor cfg)) - (flagToMaybe (configHcPath cfg)) - (flagToMaybe (configHcPkg cfg)) - (mkProgramDb cfg (configPrograms cfg)) - (lessVerbose verbosity) - - -- The InstalledPackageIndex of all installed packages - installedPackageSet :: InstalledPackageIndex - <- getInstalledPackages (lessVerbose verbosity) comp - packageDbs programDb - - -- The set of package names which are "shadowed" by internal - -- packages, and which component they map to - let internalPackageSet :: Set LibraryName - internalPackageSet = getInternalLibraries pkg_descr0 - - -- Make a data structure describing what components are enabled. - let enabled :: ComponentRequestedSpec - enabled = case mb_cname of - Just cname -> OneComponentRequestedSpec cname - Nothing -> ComponentRequestedSpec - -- The flag name (@--enable-tests@) is a - -- little bit of a misnomer, because - -- just passing this flag won't - -- "enable", in our internal - -- nomenclature; it's just a request; a - -- @buildable: False@ might make it - -- not possible to enable. - { testsRequested = fromFlag (configTests cfg) - , benchmarksRequested = - fromFlag (configBenchmarks cfg) } - -- Some sanity checks related to enabling components. - when (isJust mb_cname - && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $ - die' verbosity $ - "--enable-tests/--enable-benchmarks are incompatible with" ++ - " explicitly specifying a component to configure." - - -- Some sanity checks related to dynamic/static linking. - when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ - die' verbosity $ - "--enable-executable-dynamic and --enable-executable-static" ++ - " are incompatible with each other." - - -- allConstraints: The set of all 'Dependency's we have. Used ONLY - -- to 'configureFinalizedPackage'. - -- requiredDepsMap: A map from 'PackageName' to the specifically - -- required 'InstalledPackageInfo', due to --dependency - -- - -- NB: These constraints are to be applied to ALL components of - -- a package. Thus, it's not an error if allConstraints contains - -- more constraints than is necessary for a component (another - -- component might need it.) - -- - -- NB: The fact that we bundle all the constraints together means - -- that is not possible to configure a test-suite to use one - -- version of a dependency, and the executable to use another. - (allConstraints :: [PackageVersionConstraint], - requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo) - <- either (die' verbosity) return $ - combinedConstraints (configConstraints cfg) - (configDependencies cfg) - installedPackageSet - - -- pkg_descr: The resolved package description, that does not contain any - -- conditionals, because we have an assignment for - -- every flag, either picking them ourselves using a - -- simple naive algorithm, or having them be passed to - -- us by 'configConfigurationsFlags') - -- flags: The 'FlagAssignment' that the conditionals were - -- resolved with. - -- - -- NB: Why doesn't finalizing a package also tell us what the - -- dependencies are (e.g. when we run the naive algorithm, - -- we are checking if dependencies are satisfiable)? The - -- primary reason is that we may NOT have done any solving: - -- if the flags are all chosen for us, this step is a simple - -- matter of flattening according to that assignment. It's - -- cleaner to then configure the dependencies afterwards. - (pkg_descr :: PackageDescription, - flags :: FlagAssignment) - <- configureFinalizedPackage verbosity cfg enabled - allConstraints - (dependencySatisfiable - use_external_internal_deps - (fromFlagOrDefault False (configExactConfiguration cfg)) - (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) - (packageName pkg_descr0) - installedPackageSet - internalPackageSet - requiredDepsMap) - comp - compPlatform - pkg_descr0 - - debug verbosity $ "Finalized package description:\n" - ++ showPackageDescription pkg_descr - - let cabalFileDir = maybe "." takeDirectory $ - flagToMaybe (configCabalFilePath cfg) - checkCompilerProblems verbosity comp pkg_descr enabled - checkPackageProblems verbosity cabalFileDir pkg_descr0 - (updatePackageDescription pbi pkg_descr) - - -- The list of 'InstalledPackageInfo' recording the selected - -- dependencies on external packages. - -- - -- Invariant: For any package name, there is at most one package - -- in externalPackageDeps which has that name. - -- - -- NB: The dependency selection is global over ALL components - -- in the package (similar to how allConstraints and - -- requiredDepsMap are global over all components). In particular, - -- if *any* component (post-flag resolution) has an unsatisfiable - -- dependency, we will fail. This can sometimes be undesirable - -- for users, see #1786 (benchmark conflicts with executable), - -- - -- In the presence of Backpack, these package dependencies are - -- NOT complete: they only ever include the INDEFINITE - -- dependencies. After we apply an instantiation, we'll get - -- definite references which constitute extra dependencies. - -- (Why not have cabal-install pass these in explicitly? - -- For one it's deterministic; for two, we need to associate - -- them with renamings which would require a far more complicated - -- input scheme than what we have today.) - externalPkgDeps :: [PreExistingComponent] - <- configureDependencies - verbosity - use_external_internal_deps - internalPackageSet - installedPackageSet - requiredDepsMap - pkg_descr - enabled - - -- Compute installation directory templates, based on user - -- configuration. - -- - -- TODO: Move this into a helper function. - defaultDirs :: InstallDirTemplates - <- defaultInstallDirs' use_external_internal_deps - (compilerFlavor comp) - (fromFlag (configUserInstall cfg)) - (hasLibs pkg_descr) - let installDirs :: InstallDirTemplates - installDirs = combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs cfg) - - -- Check languages and extensions - -- TODO: Move this into a helper function. - let langlist = nub $ catMaybes $ map defaultLanguage - (enabledBuildInfos pkg_descr enabled) - let langs = unsupportedLanguages comp langlist - when (not (null langs)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following languages which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow langs) - let extlist = nub $ concatMap allExtensions - (enabledBuildInfos pkg_descr enabled) - let exts = unsupportedExtensions comp extlist - when (not (null exts)) $ - die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0) - ++ " requires the following language extensions which are not " - ++ "supported by " ++ prettyShow (compilerId comp) ++ ": " - ++ intercalate ", " (map prettyShow exts) - - -- Check foreign library build requirements - let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] - let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs - when (not (null unsupportedFLibs)) $ - die' verbosity $ "Cannot build some foreign libraries: " - ++ intercalate "," unsupportedFLibs - - -- Configure certain external build tools, see below for which ones. - let requiredBuildTools = do - bi <- enabledBuildInfos pkg_descr enabled - -- First, we collect any tool dep that we know is external. This is, - -- in practice: - -- - -- 1. `build-tools` entries on the whitelist - -- - -- 2. `build-tool-depends` that aren't from the current package. - let externBuildToolDeps = - [ LegacyExeDependency (unUnqualComponentName eName) versionRange - | buildTool@(ExeDependency _ eName versionRange) - <- getAllToolDependencies pkg_descr bi - , not $ isInternal pkg_descr buildTool ] - -- Second, we collect any build-tools entry we don't know how to - -- desugar. We'll never have any idea how to build them, so we just - -- hope they are already on the PATH. - let unknownBuildTools = - [ buildTool - | buildTool <- buildTools bi - , Nothing == desugarBuildTool pkg_descr buildTool ] - externBuildToolDeps ++ unknownBuildTools - - programDb' <- - configureAllKnownPrograms (lessVerbose verbosity) programDb - >>= configureRequiredPrograms verbosity requiredBuildTools - - (pkg_descr', programDb'') <- - configurePkgconfigPackages verbosity pkg_descr programDb' enabled - - -- Compute internal component graph - -- - -- The general idea is that we take a look at all the source level - -- components (which may build-depends on each other) and form a graph. - -- From there, we build a ComponentLocalBuildInfo for each of the - -- components, which lets us actually build each component. - -- internalPackageSet - -- use_external_internal_deps - (buildComponents :: [ComponentLocalBuildInfo], - packageDependsIndex :: InstalledPackageIndex) <- - runLogProgress verbosity $ configureComponentLocalBuildInfos - verbosity - use_external_internal_deps - enabled - (fromFlagOrDefault False (configDeterministic cfg)) - (configIPID cfg) - (configCID cfg) - pkg_descr - externalPkgDeps - (configConfigurationsFlags cfg) - (configInstantiateWith cfg) - installedPackageSet - comp - - -- Decide if we're going to compile with split sections. - split_sections :: Bool <- - if not (fromFlag $ configSplitSections cfg) - then return False - else case compilerFlavor comp of - GHC | compilerVersion comp >= mkVersion [8,0] - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-sections; ignoring") - return False - - -- Decide if we're going to compile with split objects. - split_objs :: Bool <- - if not (fromFlag $ configSplitObjs cfg) - then return False - else case compilerFlavor comp of - _ | split_sections - -> do warn verbosity - ("--enable-split-sections and " ++ - "--enable-split-objs are mutually" ++ - "exclusive; ignoring the latter") - return False - GHC - -> return True - GHCJS - -> return True - _ -> do warn verbosity - ("this compiler does not support " ++ - "--enable-split-objs; ignoring") - return False - - let ghciLibByDefault = - case compilerId comp of - CompilerId GHC _ -> - -- If ghc is non-dynamic, then ghci needs object files, - -- so we build one by default. - -- - -- Technically, archive files should be sufficient for ghci, - -- but because of GHC bug #8942, it has never been safe to - -- rely on them. By the time that bug was fixed, ghci had - -- been changed to read shared libraries instead of archive - -- files (see next code block). - not (GHC.isDynamic comp) - CompilerId GHCJS _ -> - not (GHCJS.isDynamic comp) - _ -> False - - let sharedLibsByDefault - | fromFlag (configDynExe cfg) = - -- build a shared library if dynamically-linked - -- executables are requested - True - | otherwise = case compilerId comp of - CompilerId GHC _ -> - -- if ghc is dynamic, then ghci needs a shared - -- library, so we build one by default. - GHC.isDynamic comp - CompilerId GHCJS _ -> - GHCJS.isDynamic comp - _ -> False - withSharedLib_ = - -- build shared libraries if required by GHC or by the - -- executable linking mode, but allow the user to force - -- building only static library archives with - -- --disable-shared. - fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg - - withStaticLib_ = - -- build a static library (all dependent libraries rolled - -- into a huge .a archive) via GHCs -staticlib flag. - fromFlagOrDefault False $ configStaticLib cfg - - withDynExe_ = fromFlag $ configDynExe cfg - - withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg - when (withDynExe_ && not withSharedLib_) $ warn verbosity $ - "Executables will use dynamic linking, but a shared library " - ++ "is not being built. Linking will fail if any executables " - ++ "depend on the library." - - setProfLBI <- configureProfiling verbosity cfg comp - - setCoverageLBI <- configureCoverage verbosity cfg comp - - - - -- Turn off library and executable stripping when `debug-info` is set - -- to anything other than zero. - let - strip_libexe s f = - let defaultStrip = fromFlagOrDefault True (f cfg) - in case fromFlag (configDebugInfo cfg) of - NoDebugInfo -> return defaultStrip - _ -> case f cfg of - Flag True -> do - warn verbosity $ "Setting debug-info implies " - ++ s ++ "-stripping: False" - return False - - _ -> return False - - strip_lib <- strip_libexe "library" configStripLibs - strip_exe <- strip_libexe "executable" configStripExes - - - let reloc = fromFlagOrDefault False $ configRelocatable cfg - - let buildComponentsMap = - foldl' (\m clbi -> Map.insertWith (++) - (componentLocalName clbi) [clbi] m) - Map.empty buildComponents - - let lbi = (setCoverageLBI . setProfLBI) - LocalBuildInfo { - configFlags = cfg, - flagAssignment = flags, - componentEnabledSpec = enabled, - extraConfigArgs = [], -- Currently configure does not - -- take extra args, but if it - -- did they would go here. - installDirTemplates = installDirs, - compiler = comp, - hostPlatform = compPlatform, - buildDir = buildDir, - cabalFilePath = flagToMaybe (configCabalFilePath cfg), - componentGraph = Graph.fromDistinctList buildComponents, - componentNameMap = buildComponentsMap, - installedPkgs = packageDependsIndex, - pkgDescrFile = Nothing, - localPkgDescr = pkg_descr', - withPrograms = programDb'', - withVanillaLib = fromFlag $ configVanillaLib cfg, - withSharedLib = withSharedLib_, - withStaticLib = withStaticLib_, - withDynExe = withDynExe_, - withFullyStaticExe = withFullyStaticExe_, - withProfLib = False, - withProfLibDetail = ProfDetailNone, - withProfExe = False, - withProfExeDetail = ProfDetailNone, - withOptimization = fromFlag $ configOptimization cfg, - withDebugInfo = fromFlag $ configDebugInfo cfg, - withGHCiLib = fromFlagOrDefault ghciLibByDefault $ - configGHCiLib cfg, - splitSections = split_sections, - splitObjs = split_objs, - stripExes = strip_exe, - stripLibs = strip_lib, - exeCoverage = False, - libCoverage = False, - withPackageDB = packageDbs, - progPrefix = fromFlag $ configProgPrefix cfg, - progSuffix = fromFlag $ configProgSuffix cfg, - relocatable = reloc - } - - when reloc (checkRelocatable verbosity pkg_descr lbi) - - -- TODO: This is not entirely correct, because the dirs may vary - -- across libraries/executables - let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest - relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi - - -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to - -- cabal configure, is only a hidden option. It allows packages - -- to be relocatable with their package database. This however - -- breaks when the Paths_* or other includes are used that - -- contain hard coded paths. This is still an open TODO. - -- - -- Allowing ${pkgroot} here, however requires less custom hooks - -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 - unless (isAbsolute (prefix dirs) - || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $ - "expected an absolute directory name for --prefix: " ++ prefix dirs - - when ("${pkgroot}" `isPrefixOf` prefix dirs) $ - warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs - ++ " will not work if you rely on the Path_* module " - ++ " or other hard coded paths. Cabal does not yet " - ++ " support fully relocatable builds! " - ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" - ++ " #4097 #4291 #4872" - - info verbosity $ "Using " ++ prettyShow currentCabalId - ++ " compiled by " ++ prettyShow currentCompilerId - info verbosity $ "Using compiler: " ++ showCompilerId comp - info verbosity $ "Using install prefix: " ++ prefix dirs - - let dirinfo name dir isPrefixRelative = - info verbosity $ name ++ " installed in: " ++ dir ++ relNote - where relNote = case buildOS of - Windows | not (hasLibs pkg_descr) - && isNothing isPrefixRelative - -> " (fixed location)" - _ -> "" - - dirinfo "Executables" (bindir dirs) (bindir relative) - dirinfo "Libraries" (libdir dirs) (libdir relative) - dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) - dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) - dirinfo "Data files" (datadir dirs) (datadir relative) - dirinfo "Documentation" (docdir dirs) (docdir relative) - dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) - - sequence_ [ reportProgram verbosity prog configuredProg - | (prog, configuredProg) <- knownPrograms programDb'' ] - - return lbi - - where - verbosity = fromFlag (configVerbosity cfg) - -mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb -mkProgramDb cfg initialProgramDb = programDb - where - programDb = userSpecifyArgss (configProgramArgs cfg) - . userSpecifyPaths (configProgramPaths cfg) - . setProgramSearchPath searchpath - $ initialProgramDb - searchpath = getProgramSearchPath initialProgramDb - ++ map ProgramSearchPathDir - (fromNubList $ configProgramPathExtra cfg) - --- ----------------------------------------------------------------------------- --- Helper functions for configure - --- | Check if the user used any deprecated flags. -checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () -checkDeprecatedFlags verbosity cfg = do - unless (configProfExe cfg == NoFlag) $ do - let enable | fromFlag (configProfExe cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-executable-profiling is deprecated. " - ++ "Please use --" ++ enable ++ "-profiling instead.") - - unless (configLibCoverage cfg == NoFlag) $ do - let enable | fromFlag (configLibCoverage cfg) = "enable" - | otherwise = "disable" - warn verbosity - ("The flag --" ++ enable ++ "-library-coverage is deprecated. " - ++ "Please use --" ++ enable ++ "-coverage instead.") - --- | Sanity check: if '--exact-configuration' was given, ensure that the --- complete flag assignment was specified on the command line. -checkExactConfiguration - :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () -checkExactConfiguration verbosity pkg_descr0 cfg = - when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do - let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) - allFlags = map flagName . genPackageFlags $ pkg_descr0 - diffFlags = allFlags \\ cmdlineFlags - when (not . null $ diffFlags) $ - die' verbosity $ "'--exact-configuration' was given, " - ++ "but the following flags were not specified: " - ++ intercalate ", " (map show diffFlags) - --- | Create a PackageIndex that makes *any libraries that might be* --- defined internally to this package look like installed packages, in --- case an executable should refer to any of them as dependencies. --- --- It must be *any libraries that might be* defined rather than the --- actual definitions, because these depend on conditionals in the .cabal --- file, and we haven't resolved them yet. finalizePD --- does the resolution of conditionals, and it takes internalPackageSet --- as part of its input. -getInternalLibraries :: GenericPackageDescription - -> Set LibraryName -getInternalLibraries pkg_descr0 = - -- TODO: some day, executables will be fair game here too! - let pkg_descr = flattenPackageDescription pkg_descr0 - in Set.fromList (map libName (allLibraries pkg_descr)) - --- | Returns true if a dependency is satisfiable. This function may --- report a dependency satisfiable even when it is not, but not vice --- versa. This is to be passed to finalize -dependencySatisfiable - :: Bool -- ^ use external internal deps? - -> Bool -- ^ exact configuration? - -> Bool -- ^ allow depending on private libs? - -> PackageName - -> InstalledPackageIndex -- ^ installed set - -> Set LibraryName -- ^ library components - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ required dependencies - -> (Dependency -> Bool) -dependencySatisfiable - use_external_internal_deps - exact_config - allow_private_deps - pn installedPackageSet packageLibraries requiredDepsMap - (Dependency depName vr sublibs) - | exact_config - -- When we're given '--exact-configuration', we assume that all - -- dependencies and flags are exactly specified on the command - -- line. Thus we only consult the 'requiredDepsMap'. Note that - -- we're not doing the version range check, so if there's some - -- dependency that wasn't specified on the command line, - -- 'finalizePD' will fail. - -- TODO: mention '--exact-configuration' in the error message - -- when this fails? - = if isInternalDep && not use_external_internal_deps - -- Except for internal deps, when we're NOT per-component mode; - -- those are just True. - then internalDepSatisfiable - else - -- Backward compatibility for the old sublibrary syntax - (sublibs == mainLibSet - && Map.member - (pn, CLibName $ LSubLibName $ - packageNameToUnqualComponentName depName) - requiredDepsMap) - - || all visible sublibs - - | isInternalDep - = if use_external_internal_deps - -- When we are doing per-component configure, we now need to - -- test if the internal dependency is in the index. This has - -- DIFFERENT semantics from normal dependency satisfiability. - then internalDepSatisfiableExternally - -- If a 'PackageName' is defined by an internal component, the dep is - -- satisfiable (we're going to build it ourselves) - else internalDepSatisfiable - - | otherwise - = depSatisfiable - - where - -- Internal dependency is when dependency is the same as package. - isInternalDep = pn == depName - - depSatisfiable = - not . null $ PackageIndex.lookupDependency installedPackageSet depName vr - - internalDepSatisfiable = - Set.isSubsetOf (NES.toSet sublibs) packageLibraries - internalDepSatisfiableExternally = - all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs - - -- Check whether a library exists and is visible. - -- We don't disambiguate between dependency on non-existent or private - -- library yet, so we just return a bool and later report a generic error. - visible lib = maybe - False -- Does not even exist (wasn't in the depsMap) - (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic - -- If the override is enabled, the visibility does - -- not matter (it's handled externally) - || allow_private_deps - -- If it's a library of the same package then it's - -- always visible. - -- This is only triggered when passing a component - -- of the same package as --dependency, such as in: - -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs - || pkgName (IPI.sourcePackageId ipi) == pn) - maybeIPI - where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap - --- | Finalize a generic package description. The workhorse is --- 'finalizePD' but there's a bit of other nattering --- about necessary. --- --- TODO: what exactly is the business with @flaggedTests@ and --- @flaggedBenchmarks@? -configureFinalizedPackage - :: Verbosity - -> ConfigFlags - -> ComponentRequestedSpec - -> [PackageVersionConstraint] - -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable. - -- Might say it's satisfiable even when not. - -> Compiler - -> Platform - -> GenericPackageDescription - -> IO (PackageDescription, FlagAssignment) -configureFinalizedPackage verbosity cfg enabled - allConstraints satisfies comp compPlatform pkg_descr0 = do - - (pkg_descr0', flags) <- - case finalizePD - (configConfigurationsFlags cfg) - enabled - satisfies - compPlatform - (compilerInfo comp) - allConstraints - pkg_descr0 - of Right r -> return r - Left missing -> - die' verbosity $ "Encountered missing or private dependencies:\n" - ++ (render . nest 4 . sep . punctuate comma - . map (pretty . simplifyDependency) - $ missing) - - -- add extra include/lib dirs as specified in cfg - -- we do it here so that those get checked too - let pkg_descr = addExtraIncludeLibDirs pkg_descr0' - - unless (nullFlagAssignment flags) $ - info verbosity $ "Flags chosen: " - ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value - | (fn, value) <- unFlagAssignment flags ] - - return (pkg_descr, flags) - where - addExtraIncludeLibDirs pkg_descr = - let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg - , extraFrameworkDirs = configExtraFrameworkDirs cfg - , includeDirs = configExtraIncludeDirs cfg} - modifyLib l = l{ libBuildInfo = libBuildInfo l - `mappend` extraBi } - modifyExecutable e = e{ buildInfo = buildInfo e - `mappend` extraBi} - modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f - `mappend` extraBi} - modifyTestsuite t = t{ testBuildInfo = testBuildInfo t - `mappend` extraBi} - modifyBenchmark b = b{ benchmarkBuildInfo = benchmarkBuildInfo b - `mappend` extraBi} - in pkg_descr - { library = modifyLib `fmap` library pkg_descr - , subLibraries = modifyLib `map` subLibraries pkg_descr - , executables = modifyExecutable `map` executables pkg_descr - , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr - , testSuites = modifyTestsuite `map` testSuites pkg_descr - , benchmarks = modifyBenchmark `map` benchmarks pkg_descr - } - --- | Check for use of Cabal features which require compiler support -checkCompilerProblems - :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () -checkCompilerProblems verbosity comp pkg_descr enabled = do - unless (renamingPackageFlagsSupported comp || - all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) - (enabledBuildInfos pkg_descr enabled)) $ - die' verbosity $ - "Your compiler does not support thinning and renaming on " - ++ "package flags. To use this feature you must use " - ++ "GHC 7.9 or later." - - when (any (not.null.reexportedModules) (allLibraries pkg_descr) - && not (reexportedModulesSupported comp)) $ - die' verbosity $ - "Your compiler does not support module re-exports. To use " - ++ "this feature you must use GHC 7.9 or later." - - when (any (not.null.signatures) (allLibraries pkg_descr) - && not (backpackSupported comp)) $ - die' verbosity $ - "Your compiler does not support Backpack. To use " - ++ "this feature you must use GHC 8.1 or later." - --- | Select dependencies for the package. -configureDependencies - :: Verbosity - -> UseExternalInternalDeps - -> Set LibraryName - -> InstalledPackageIndex -- ^ installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps - -> PackageDescription - -> ComponentRequestedSpec - -> IO [PreExistingComponent] -configureDependencies verbosity use_external_internal_deps - packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do - let failedDeps :: [FailedDependency] - allPkgDeps :: [ResolvedDependency] - (failedDeps, allPkgDeps) = partitionEithers $ concat - [ fmap (\s -> (dep, s)) <$> status - | dep <- enabledBuildDepends pkg_descr enableSpec - , let status = selectDependency (package pkg_descr) - packageLibraries installedPackageSet - requiredDepsMap use_external_internal_deps dep ] - - internalPkgDeps = [ pkgid - | (_, InternalDependency pkgid) <- allPkgDeps ] - -- NB: we have to SAVE the package name, because this is the only - -- way we can be able to resolve package names in the package - -- description. - externalPkgDeps = [ pec - | (_, ExternalDependency pec) <- allPkgDeps ] - - when (not (null internalPkgDeps) - && not (newPackageDepsBehaviour pkg_descr)) $ - die' verbosity $ "The field 'build-depends: " - ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps) - ++ "' refers to a library which is defined within the same " - ++ "package. To use this feature the package must specify at " - ++ "least 'cabal-version: >= 1.8'." - - reportFailedDependencies verbosity failedDeps - reportSelectedDependencies verbosity allPkgDeps - - return externalPkgDeps - --- | Select and apply coverage settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureCoverage :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureCoverage verbosity cfg comp = do - let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) - tryLibCoverage = fromFlagOrDefault tryExeCoverage - (mappend (configCoverage cfg) (configLibCoverage cfg)) - if coverageSupported comp - then do - let apply lbi = lbi { libCoverage = tryLibCoverage - , exeCoverage = tryExeCoverage - } - return apply - else do - let apply lbi = lbi { libCoverage = False - , exeCoverage = False - } - when (tryExeCoverage || tryLibCoverage) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "program coverage. Program coverage has been disabled.") - return apply - --- | Compute the effective value of the profiling flags --- @--enable-library-profiling@ and @--enable-executable-profiling@ --- from the specified 'ConfigFlags'. This may be useful for --- external Cabal tools which need to interact with Setup in --- a backwards-compatible way: the most predictable mechanism --- for enabling profiling across many legacy versions is to --- NOT use @--enable-profiling@ and use those two flags instead. --- --- Note that @--enable-executable-profiling@ also affects profiling --- of benchmarks and (non-detailed) test suites. -computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib -}, Bool {- exe -}) -computeEffectiveProfiling cfg = - -- The --profiling flag sets the default for both libs and exes, - -- but can be overidden by --library-profiling, or the old deprecated - -- --executable-profiling flag. - -- - -- The --profiling-detail and --library-profiling-detail flags behave - -- similarly - let tryExeProfiling = fromFlagOrDefault False - (mappend (configProf cfg) (configProfExe cfg)) - tryLibProfiling = fromFlagOrDefault tryExeProfiling - (mappend (configProf cfg) (configProfLib cfg)) - in (tryLibProfiling, tryExeProfiling) - --- | Select and apply profiling settings for the build based on the --- 'ConfigFlags' and 'Compiler'. -configureProfiling :: Verbosity -> ConfigFlags -> Compiler - -> IO (LocalBuildInfo -> LocalBuildInfo) -configureProfiling verbosity cfg comp = do - let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg - - tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault - (configProfDetail cfg) - tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault - (mappend - (configProfDetail cfg) - (configProfLibDetail cfg)) - - checkProfileLevel (ProfDetailOther other) = do - warn verbosity - ("Unknown profiling detail level '" ++ other - ++ "', using default.\nThe profiling detail levels are: " - ++ intercalate ", " - [ name | (name, _, _) <- knownProfDetailLevels ]) - return ProfDetailDefault - checkProfileLevel other = return other - - (exeProfWithoutLibProf, applyProfiling) <- - if profilingSupported comp - then do - exeLevel <- checkProfileLevel tryExeProfileLevel - libLevel <- checkProfileLevel tryLibProfileLevel - let apply lbi = lbi { withProfLib = tryLibProfiling - , withProfLibDetail = libLevel - , withProfExe = tryExeProfiling - , withProfExeDetail = exeLevel - } - return (tryExeProfiling && not tryLibProfiling, apply) - else do - let apply lbi = lbi { withProfLib = False - , withProfLibDetail = ProfDetailNone - , withProfExe = False - , withProfExeDetail = ProfDetailNone - } - when (tryExeProfiling || tryLibProfiling) $ warn verbosity - ("The compiler " ++ showCompilerId comp ++ " does not support " - ++ "profiling. Profiling has been disabled.") - return (False, apply) - - when exeProfWithoutLibProf $ warn verbosity - ("Executables will be built with profiling, but library " - ++ "profiling is disabled. Linking will fail if any executables " - ++ "depend on the library.") - - return applyProfiling - --- ----------------------------------------------------------------------------- --- Configuring package dependencies - -reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () -reportProgram verbosity prog Nothing - = info verbosity $ "No " ++ programName prog ++ " found" -reportProgram verbosity prog (Just configuredProg) - = info verbosity $ "Using " ++ programName prog ++ version ++ location - where location = case programLocation configuredProg of - FoundOnSystem p -> " found on system at: " ++ p - UserSpecified p -> " given by user at: " ++ p - version = case programVersion configuredProg of - Nothing -> "" - Just v -> " version " ++ prettyShow v - -hackageUrl :: String -hackageUrl = "http://hackage.haskell.org/package/" - -type ResolvedDependency = (Dependency, DependencyResolution) - -data DependencyResolution - -- | An external dependency from the package database, OR an - -- internal dependency which we are getting from the package - -- database. - = ExternalDependency PreExistingComponent - -- | An internal dependency ('PackageId' should be a library name) - -- which we are going to have to build. (The - -- 'PackageId' here is a hack to get a modest amount of - -- polymorphism out of the 'Package' typeclass.) - | InternalDependency PackageId - -data FailedDependency = DependencyNotExists PackageName - | DependencyMissingInternal PackageName LibraryName - | DependencyNoVersion Dependency - --- | Test for a package dependency and record the version we have installed. -selectDependency :: PackageId -- ^ Package id of current package - -> Set LibraryName -- ^ package libraries - -> InstalledPackageIndex -- ^ Installed packages - -> Map (PackageName, ComponentName) InstalledPackageInfo - -- ^ Packages for which we have been given specific deps to - -- use - -> UseExternalInternalDeps -- ^ Are we configuring a - -- single component? - -> Dependency - -> [Either FailedDependency DependencyResolution] -selectDependency pkgid internalIndex installedIndex requiredDepsMap - use_external_internal_deps - (Dependency dep_pkgname vr libs) = - -- If the dependency specification matches anything in the internal package - -- index, then we prefer that match to anything in the second. - -- For example: - -- - -- Name: MyLibrary - -- Version: 0.1 - -- Library - -- .. - -- Executable my-exec - -- build-depends: MyLibrary - -- - -- We want "build-depends: MyLibrary" always to match the internal library - -- even if there is a newer installed library "MyLibrary-0.2". - if dep_pkgname == pn - then - if use_external_internal_deps - then do_external_internal <$> NES.toList libs - else do_internal <$> NES.toList libs - else - do_external_external <$> NES.toList libs - where - pn = packageName pkgid - - -- It's an internal library, and we're not per-component build - do_internal lib - | Set.member lib internalIndex - = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid - - | otherwise - = Left $ DependencyMissingInternal dep_pkgname lib - - -- We have to look it up externally - do_external_external :: LibraryName -> Either FailedDependency DependencyResolution - do_external_external lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - -- Otherwise we just pick an arbitrary instance of the latest version. - Nothing -> case pickLastIPI $ PackageIndex.lookupDependency installedIndex dep_pkgname vr of - Nothing -> Left (DependencyNotExists dep_pkgname) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution - do_external_internal lib = do - ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of - -- If we know the exact pkg to use, then use it. - Just pkginstance -> Right pkginstance - Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of - -- It's an internal library, being looked up externally - Nothing -> Left (DependencyMissingInternal dep_pkgname lib) - Just pkg -> Right pkg - return $ ExternalDependency $ ipiToPreExistingComponent ipi - - pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo - pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs - -reportSelectedDependencies :: Verbosity - -> [ResolvedDependency] -> IO () -reportSelectedDependencies verbosity deps = - info verbosity $ unlines - [ "Dependency " ++ prettyShow (simplifyDependency dep) - ++ ": using " ++ prettyShow pkgid - | (dep, resolution) <- deps - , let pkgid = case resolution of - ExternalDependency pkg' -> packageId pkg' - InternalDependency pkgid' -> pkgid' ] - -reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () -reportFailedDependencies _ [] = return () -reportFailedDependencies verbosity failed = - die' verbosity (intercalate "\n\n" (map reportFailedDependency failed)) - - where - reportFailedDependency (DependencyNotExists pkgname) = - "there is no version of " ++ prettyShow pkgname ++ " installed.\n" - ++ "Perhaps you need to download and install it from\n" - ++ hackageUrl ++ prettyShow pkgname ++ "?" - - reportFailedDependency (DependencyMissingInternal pkgname lib) = - "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n" - ++ "Perhaps you need to configure and install it first?\n" - ++ "(This library was defined by " ++ prettyShow pkgname ++ ")" - - reportFailedDependency (DependencyNoVersion dep) = - "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n" - --- | List all installed packages in the given package databases. --- Non-existent package databases do not cause errors, they just get skipped --- with a warning and treated as empty ones, since technically they do not --- contain any package. -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -- ^ The stack of package databases. - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packageDBs progdb = do - when (null packageDBs) $ - die' verbosity $ "No package databases have been specified. If you use " - ++ "--package-db=clear, you must follow it with --package-db= " - ++ "with 'global', 'user' or a specific file." - - info verbosity "Reading installed packages..." - -- do not check empty packagedbs (ghc-pkg would error out) - packageDBs' <- filterM packageDBExists packageDBs - case compilerFlavor comp of - GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb - GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb - UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb - HaskellSuite {} -> - HaskellSuite.getInstalledPackages verbosity packageDBs' progdb - flv -> die' verbosity $ "don't know how to find the installed packages for " - ++ prettyShow flv - where - packageDBExists (SpecificPackageDB path) = do - exists <- doesPathExist path - unless exists $ - warn verbosity $ "Package db " <> path <> " does not exist yet" - return exists - -- Checking the user and global package dbs is more complicated and needs - -- way more data. Also ghc-pkg won't error out unless the user/global - -- pkgdb is overridden with an empty one, so we just don't check for them. - packageDBExists UserPackageDB = pure True - packageDBExists GlobalPackageDB = pure True - --- | Like 'getInstalledPackages', but for a single package DB. --- --- NB: Why isn't this always a fall through to 'getInstalledPackages'? --- That is because 'getInstalledPackages' performs some sanity checks --- on the package database stack in question. However, when sandboxes --- are involved these sanity checks are not desirable. -getPackageDBContents :: Verbosity -> Compiler - -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity comp packageDB progdb = do - info verbosity "Reading installed packages..." - case compilerFlavor comp of - GHC -> GHC.getPackageDBContents verbosity packageDB progdb - GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb - -- For other compilers, try to fall back on 'getInstalledPackages'. - _ -> getInstalledPackages verbosity comp [packageDB] progdb - - --- | A set of files (or directories) that can be monitored to detect when --- there might have been a change in the installed packages. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Compiler - -> PackageDBStack - -> ProgramDb -> Platform - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform = - case compilerFlavor comp of - GHC -> GHC.getInstalledPackagesMonitorFiles - verbosity platform progdb packageDBs - other -> do - warn verbosity $ "don't know how to find change monitoring files for " - ++ "the installed package databases for " ++ prettyShow other - return [] - --- | The user interface specifies the package dbs to use with a combination of --- @--global@, @--user@ and @--package-db=global|user|clear|$file@. --- This function combines the global/user flag and interprets the package-db --- flag into a single package db stack. --- -interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack -interpretPackageDbFlags userInstall specificDBs = - extra initialStack specificDBs - where - initialStack | userInstall = [GlobalPackageDB, UserPackageDB] - | otherwise = [GlobalPackageDB] - - extra dbs' [] = dbs' - extra _ (Nothing:dbs) = extra [] dbs - extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs - --- We are given both --constraint="foo < 2.0" style constraints and also --- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". --- --- When finalising the package we have to take into account the specific --- installed deps we've been given, and the finalise function expects --- constraints, so we have to translate these deps into version constraints. --- --- But after finalising we then have to make sure we pick the right specific --- deps in the end. So we still need to remember which installed packages to --- pick. -combinedConstraints - :: [PackageVersionConstraint] - -> [GivenComponent] - -> InstalledPackageIndex - -> Either String ([PackageVersionConstraint], - Map (PackageName, ComponentName) InstalledPackageInfo) -combinedConstraints constraints dependencies installedPackages = do - - when (not (null badComponentIds)) $ - Left $ render $ text "The following package dependencies were requested" - $+$ nest 4 (dispDependencies badComponentIds) - $+$ text "however the given installed package instance does not exist." - - --TODO: we don't check that all dependencies are used! - - return (allConstraints, idConstraintMap) - - where - allConstraints :: [PackageVersionConstraint] - allConstraints = constraints - ++ [ thisPackageVersionConstraint (packageId pkg) - | (_, _, _, Just pkg) <- dependenciesPkgInfo ] - - idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo - idConstraintMap = Map.fromList - -- NB: do NOT use the packageName from - -- dependenciesPkgInfo! - [ ((pn, cname), pkg) - | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ] - - -- The dependencies along with the installed package info, if it exists - dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, - Maybe InstalledPackageInfo)] - dependenciesPkgInfo = - [ (pkgname, CLibName lname, cid, mpkg) - | GivenComponent pkgname lname cid <- dependencies - , let mpkg = PackageIndex.lookupComponentId - installedPackages cid - ] - - -- If we looked up a package specified by an installed package id - -- (i.e. someone has written a hash) and didn't find it then it's - -- an error. - badComponentIds = - [ (pkgname, cname, cid) - | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ] - - dispDependencies deps = - hsep [ text "--dependency=" - <<>> quotes - (pretty pkgname - <<>> case cname of - CLibName LMainLibName -> "" - CLibName (LSubLibName n) -> ":" <<>> pretty n - _ -> ":" <<>> pretty cname - <<>> char '=' - <<>> pretty cid) - | (pkgname, cname, cid) <- deps ] - --- ----------------------------------------------------------------------------- --- Configuring program dependencies - -configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb - -> IO ProgramDb -configureRequiredPrograms verbosity deps progdb = - foldM (configureRequiredProgram verbosity) progdb deps - --- | Configure a required program, ensuring that it exists in the PATH --- (or where the user has specified the program must live) and making it --- available for use via the 'ProgramDb' interface. If the program is --- known (exists in the input 'ProgramDb'), we will make sure that the --- program matches the required version; otherwise we will accept --- any version of the program and assume that it is a simpleProgram. -configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency - -> IO ProgramDb -configureRequiredProgram verbosity progdb - (LegacyExeDependency progName verRange) = - case lookupKnownProgram progName progdb of - Nothing -> - -- Try to configure it as a 'simpleProgram' automatically - -- - -- There's a bit of a story behind this line. In old versions - -- of Cabal, there were only internal build-tools dependencies. So the - -- behavior in this case was: - -- - -- - If a build-tool dependency was internal, don't do - -- any checking. - -- - -- - If it was external, call 'configureRequiredProgram' to - -- "configure" the executable. In particular, if - -- the program was not "known" (present in 'ProgramDb'), - -- then we would just error. This was fine, because - -- the only way a program could be executed from 'ProgramDb' - -- is if some library code from Cabal actually called it, - -- and the pre-existing Cabal code only calls known - -- programs from 'defaultProgramDb', and so if it - -- is calling something else, you have a Custom setup - -- script, and in that case you are expected to register - -- the program you want to call in the ProgramDb. - -- - -- OK, so that was fine, until I (ezyang, in 2016) refactored - -- Cabal to support per-component builds. In this case, what - -- was previously an internal build-tool dependency now became - -- an external one, and now previously "internal" dependencies - -- are now external. But these are permitted to exist even - -- when they are not previously configured (something that - -- can only occur by a Custom script.) - -- - -- So, I decided, "Fine, let's just accept these in any - -- case." Thus this line. The alternative would have been to - -- somehow detect when a build-tools dependency was "internal" (by - -- looking at the unflattened package description) but this - -- would also be incompatible with future work to support - -- external executable dependencies: we definitely cannot - -- assume they will be preinitialized in the 'ProgramDb'. - configureProgram verbosity (simpleProgram progName) progdb - Just prog - -- requireProgramVersion always requires the program have a version - -- but if the user says "build-depends: foo" ie no version constraint - -- then we should not fail if we cannot discover the program version. - | verRange == anyVersion -> do - (_, progdb') <- requireProgram verbosity prog progdb - return progdb' - | otherwise -> do - (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb - return progdb' - --- ----------------------------------------------------------------------------- --- Configuring pkg-config package dependencies - -configurePkgconfigPackages :: Verbosity -> PackageDescription - -> ProgramDb -> ComponentRequestedSpec - -> IO (PackageDescription, ProgramDb) -configurePkgconfigPackages verbosity pkg_descr progdb enabled - | null allpkgs = return (pkg_descr, progdb) - | otherwise = do - (_, _, progdb') <- requireProgramVersion - (lessVerbose verbosity) pkgConfigProgram - (orLaterVersion $ mkVersion [0,9,0]) progdb - traverse_ requirePkg allpkgs - mlib' <- traverse addPkgConfigBILib (library pkg_descr) - libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) - exes' <- traverse addPkgConfigBIExe (executables pkg_descr) - tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) - benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) - let pkg_descr' = pkg_descr { library = mlib', - subLibraries = libs', executables = exes', - testSuites = tests', benchmarks = benches' } - return (pkg_descr', progdb') - - where - allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) - pkgconfig = getDbProgramOutput (lessVerbose verbosity) - pkgConfigProgram progdb - - requirePkg dep@(PkgconfigDependency pkgn range) = do - version <- pkgconfig ["--modversion", pkg] - `catchIO` (\_ -> die' verbosity notFound) - `catchExit` (\_ -> die' verbosity notFound) - let trim = dropWhile isSpace . dropWhileEnd isSpace - let v = PkgconfigVersion (toUTF8BS $ trim version) - if not (withinPkgconfigVersionRange v range) - then die' verbosity (badVersion v) - else info verbosity (depSatisfied v) - where - notFound = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but it could not be found." - badVersion v = "The pkg-config package '" ++ pkg ++ "'" - ++ versionRequirement - ++ " is required but the version installed on the" - ++ " system is version " ++ prettyShow v - depSatisfied v = "Dependency " ++ prettyShow dep - ++ ": using version " ++ prettyShow v - - versionRequirement - | isAnyPkgconfigVersion range = "" - | otherwise = " version " ++ prettyShow range - - pkg = unPkgconfigName pkgn - - -- Adds pkgconfig dependencies to the build info for a component - addPkgConfigBI compBI setCompBI comp = do - bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) - return $ setCompBI comp (compBI comp `mappend` bi) - - -- Adds pkgconfig dependencies to the build info for a library - addPkgConfigBILib = addPkgConfigBI libBuildInfo $ - \lib bi -> lib { libBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for an executable - addPkgConfigBIExe = addPkgConfigBI buildInfo $ - \exe bi -> exe { buildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a test suite - addPkgConfigBITest = addPkgConfigBI testBuildInfo $ - \test bi -> test { testBuildInfo = bi } - - -- Adds pkgconfig dependencies to the build info for a benchmark - addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ - \bench bi -> bench { benchmarkBuildInfo = bi } - - pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo - pkgconfigBuildInfo [] = return mempty - pkgconfigBuildInfo pkgdeps = do - let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ] - ccflags <- pkgconfig ("--cflags" : pkgs) - ldflags <- pkgconfig ("--libs" : pkgs) - return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) - --- | Makes a 'BuildInfo' from C compiler and linker flags. --- --- This can be used with the output from configuration programs like pkg-config --- and similar package-specific programs like mysql-config, freealut-config etc. --- For example: --- --- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] --- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] --- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) --- -ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo -ccLdOptionsBuildInfo cflags ldflags = - let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags - (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags - (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' - in mempty { - includeDirs = map (drop 2) includeDirs', - extraLibs = map (drop 2) extraLibs', - extraLibDirs = map (drop 2) extraLibDirs', - ccOptions = cflags', - ldOptions = ldflags'' - } - --- ----------------------------------------------------------------------------- --- Determining the compiler details - -configCompilerAuxEx :: ConfigFlags - -> IO (Compiler, Platform, ProgramDb) -configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg) - (flagToMaybe $ configHcPath cfg) - (flagToMaybe $ configHcPkg cfg) - programDb - (fromFlag (configVerbosity cfg)) - where - programDb = mkProgramDb cfg defaultProgramDb - -configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> Verbosity - -> IO (Compiler, Platform, ProgramDb) -configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler" -configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do - (comp, maybePlatform, programDb) <- case hcFlavor of - GHC -> GHC.configure verbosity hcPath hcPkg progdb - GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb - UHC -> UHC.configure verbosity hcPath hcPkg progdb - HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb - _ -> die' verbosity "Unknown compiler" - return (comp, fromMaybe buildPlatform maybePlatform, programDb) - --- ----------------------------------------------------------------------------- --- Testing C lib and header dependencies - --- Try to build a test C program which includes every header and links every --- lib. If that fails, try to narrow it down by preprocessing (only) and linking --- with individual headers and libs. If none is the obvious culprit then give a --- generic error message. --- TODO: produce a log file from the compiler errors, if any. -checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () -checkForeignDeps pkg lbi verbosity = - ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling - -- lucky - (return ()) - (do missingLibs <- findMissingLibs - missingHdr <- findOffendingHdr - explainErrors missingHdr missingLibs) - where - allHeaders = collectField includes - allLibs = collectField extraLibs - - ifBuildsWith headers args success failure = do - checkDuplicateHeaders - ok <- builds (makeProgram headers) args - if ok then success else failure - - -- Ensure that there is only one header with a given name - -- in either the generated (most likely by `configure`) - -- build directory (e.g. `dist/build`) or in the source directory. - -- - -- If it exists in both, we'll remove the one in the source - -- directory, as the generated should take precedence. - -- - -- C compilers like to prefer source local relative includes, - -- so the search paths provided to the compiler via -I are - -- ignored if the included file can be found relative to the - -- including file. As such we need to take drastic measures - -- and delete the offending file in the source directory. - checkDuplicateHeaders = do - let relIncDirs = filter (not . isAbsolute) (collectField includeDirs) - isHeader = isSuffixOf ".h" - genHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (buildDir lbi dir) `catchIO` (\_ -> return []) - srcHeaders <- for relIncDirs $ \dir -> - fmap (dir ) . filter isHeader <$> - listDirectory (baseDir lbi dir) `catchIO` (\_ -> return []) - let commonHeaders = concat genHeaders `intersect` concat srcHeaders - for_ commonHeaders $ \hdr -> do - warn verbosity $ "Duplicate header found in " - ++ (buildDir lbi hdr) - ++ " and " - ++ (baseDir lbi hdr) - ++ "; removing " - ++ (baseDir lbi hdr) - removeFile (baseDir lbi hdr) - - findOffendingHdr = - ifBuildsWith allHeaders ccArgs - (return Nothing) - (go . Unsafe.tail . inits $ allHeaders) -- inits always contains at least [] - where - go [] = return Nothing -- cannot happen - go (hdrs:hdrsInits) = - -- Try just preprocessing first - ifBuildsWith hdrs cppArgs - -- If that works, try compiling too - (ifBuildsWith hdrs ccArgs - (go hdrsInits) - (return . fmap Right . safeLast $ hdrs)) - (return . fmap Left . safeLast $ hdrs) - - - cppArgs = "-E":commonCppArgs -- preprocess only - ccArgs = "-c":commonCcArgs -- don't try to link - - findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) - (return []) - (filterM (fmap not . libExists) allLibs) - - libExists lib = builds (makeProgram []) (makeLdArgs [lib]) - - baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi') - - commonCppArgs = platformDefines lbi - -- TODO: This is a massive hack, to work around the - -- fact that the test performed here should be - -- PER-component (c.f. the "I'm Feeling Lucky"; we - -- should NOT be glomming everything together.) - ++ [ "-I" ++ buildDir lbi "autogen" ] - -- `configure' may generate headers in the build directory - ++ [ "-I" ++ buildDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - -- we might also reference headers from the - -- packages directory. - ++ [ "-I" ++ baseDir lbi dir - | dir <- ordNub (collectField includeDirs) - , not (isAbsolute dir)] - ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs) - , isAbsolute dir] - ++ ["-I" ++ baseDir lbi] - ++ collectField cppOptions - ++ collectField ccOptions - ++ [ "-I" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- IPI.includeDirs dep ] - -- dedupe include dirs of dependencies - -- to prevent quadratic blow-up - ] - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonCcArgs = commonCppArgs - ++ collectField ccOptions - ++ [ opt - | dep <- deps - , opt <- IPI.ccOptions dep ] - - commonLdArgs = [ "-L" ++ dir - | dir <- ordNub (collectField extraLibDirs) ] - ++ collectField ldOptions - ++ [ "-L" ++ dir - | dir <- ordNub [ dir - | dep <- deps - , dir <- IPI.libraryDirs dep ] - ] - --TODO: do we also need dependent packages' ld options? - makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs - - makeProgram hdrs = unlines $ - [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ - ["int main(int argc, char** argv) { return 0; }"] - - collectField f = concatMap f allBi - allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) - deps = PackageIndex.topologicalOrder (installedPkgs lbi) - - builds program args = do - tempDir <- getTemporaryDirectory - withTempFile tempDir ".c" $ \cName cHnd -> - withTempFile tempDir "" $ \oNname oHnd -> do - hPutStrLn cHnd program - hClose cHnd - hClose oHnd - _ <- getDbProgramOutput verbosity - gccProgram (withPrograms lbi) (cName:"-o":oNname:args) - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - - explainErrors Nothing [] = return () -- should be impossible! - explainErrors _ _ - | isNothing . lookupProgram gccProgram . withPrograms $ lbi - - = die' verbosity $ unlines - [ "No working gcc", - "This package depends on foreign library but we cannot " - ++ "find a working C compiler. If you have it in a " - ++ "non-standard location you can use the --with-gcc " - ++ "flag to specify it." ] - - explainErrors hdr libs = die' verbosity $ unlines $ - [ if plural - then "Missing dependencies on foreign libraries:" - else "Missing dependency on a foreign library:" - | missing ] - ++ case hdr of - Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] - _ -> [] - ++ case libs of - [] -> [] - [lib] -> ["* Missing (or bad) C library: " ++ lib] - _ -> ["* Missing (or bad) C libraries: " ++ - intercalate ", " libs] - ++ [if plural then messagePlural else messageSingular | missing] - ++ case hdr of - Just (Left _) -> [ headerCppMessage ] - Just (Right h) -> [ (if missing then "* " else "") - ++ "Bad header file: " ++ h - , headerCcMessage ] - _ -> [] - - where - plural = length libs >= 2 - -- Is there something missing? (as opposed to broken) - missing = not (null libs) - || case hdr of Just (Left _) -> True; _ -> False - - messageSingular = - "This problem can usually be solved by installing the system " - ++ "package that provides this library (you may need the " - ++ "\"-dev\" version). If the library is already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where it is." - ++ "If the library file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - messagePlural = - "This problem can usually be solved by installing the system " - ++ "packages that provide these libraries (you may need the " - ++ "\"-dev\" versions). If the libraries are already installed " - ++ "but in a non-standard location then you can use the flags " - ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " - ++ "where they are." - ++ "If the library files do exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCppMessage = - "If the header file does exist, it may contain errors that " - ++ "are caught by the C compiler at the preprocessing stage. " - ++ "In this case you can re-run configure with the verbosity " - ++ "flag -v3 to see the error messages." - headerCcMessage = - "The header file contains a compile error. " - ++ "You can re-run configure with the verbosity flag " - ++ "-v3 to see the error messages from the C compiler." - --- | Output package check warnings and errors. Exit if any errors. -checkPackageProblems :: Verbosity - -> FilePath - -- ^ Path to the @.cabal@ file's directory - -> GenericPackageDescription - -> PackageDescription - -> IO () -checkPackageProblems verbosity dir gpkg pkg = do - ioChecks <- checkPackageFiles verbosity pkg dir - let pureChecks = checkPackage gpkg (Just pkg) - errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] - warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] - if null errors - then traverse_ (warn verbosity) warnings - else die' verbosity (intercalate "\n\n" errors) - --- | Preform checks if a relocatable build is allowed -checkRelocatable :: Verbosity - -> PackageDescription - -> LocalBuildInfo - -> IO () -checkRelocatable verbosity pkg lbi - = sequence_ [ checkOS - , checkCompiler - , packagePrefixRelative - , depsPrefixRelative - ] - where - -- Check if the OS support relocatable builds. - -- - -- If you add new OS' to this list, and your OS supports dynamic libraries - -- and RPATH, make sure you add your OS to RPATH-support list of: - -- Distribution.Simple.GHC.getRPaths - checkOS - = unless (os `elem` [ OSX, Linux ]) - $ die' verbosity $ "Operating system: " ++ prettyShow os ++ - ", does not support relocatable builds" - where - (Platform _ os) = hostPlatform lbi - - -- Check if the Compiler support relocatable builds - checkCompiler - = unless (compilerFlavor comp `elem` [ GHC ]) - $ die' verbosity $ "Compiler: " ++ show comp ++ - ", does not support relocatable builds" - where - comp = compiler lbi - - -- Check if all the install dirs are relative to same prefix - packagePrefixRelative - = unless (relativeInstallDirs installDirs) - $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++ - show installDirs - where - -- NB: should be good enough to check this against the default - -- component ID, but if we wanted to be strictly correct we'd - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - relativeInstallDirs (InstallDirs {..}) = - all isJust - (fmap (stripPrefix p) - [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir - , docdir, mandir, htmldir, haddockdir, sysconfdir] ) - - -- Check if the library dirs of the dependencies that are in the package - -- database to which the package is installed are relative to the - -- prefix of the package - depsPrefixRelative = do - pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) - traverse_ (doCheck pkgr) ipkgs - where - doCheck pkgr ipkg - | maybe False (== pkgr) (IPI.pkgRoot ipkg) - = for_ (IPI.libraryDirs ipkg) $ \libdir -> do - -- When @prefix@ is not under @pkgroot@, - -- @shortRelativePath prefix pkgroot@ will return a path with - -- @..@s and following check will fail without @canonicalizePath@. - canonicalized <- canonicalizePath libdir - unless (p `isPrefixOf` canonicalized) $ - die' verbosity $ msg libdir - | otherwise - = return () - -- NB: should be good enough to check this against the default - -- component ID, but if we wanted to be strictly correct we'd - -- check for each ComponentId. - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - p = prefix installDirs - ipkgs = PackageIndex.allPackages (installedPkgs lbi) - msg l = "Library directory of a dependency: " ++ show l ++ - "\nis not relative to the installation prefix:\n" ++ - show p - --- ----------------------------------------------------------------------------- --- Testing foreign library requirements - -unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] -unsupportedForeignLibs comp platform = - mapMaybe (checkForeignLibSupported comp platform) - -checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String -checkForeignLibSupported comp platform flib = go (compilerFlavor comp) - where - go :: CompilerFlavor -> Maybe String - go GHC - | compilerVersion comp < mkVersion [7,8] = unsupported [ - "Building foreign libraires is only supported with GHC >= 7.8" - ] - | otherwise = goGhcPlatform platform - go _ = unsupported [ - "Building foreign libraries is currently only supported with ghc" - ] - - goGhcPlatform :: Platform -> Maybe String - goGhcPlatform (Platform X86_64 OSX ) = goGhcOsx (foreignLibType flib) - goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib) - goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) - goGhcPlatform _ = unsupported [ - "Building foreign libraries is currently only supported on OSX, " - , "Linux and Windows" - ] - - goGhcOsx :: ForeignLibType -> Maybe String - goGhcOsx ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on OSX" - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on OSX" - ] - | otherwise = - Nothing - goGhcOsx _ = unsupported [ - "We can currently only build shared foreign libraries on OSX" - ] - - goGhcLinux :: ForeignLibType -> Maybe String - goGhcLinux ForeignLibNativeShared - | not (null (foreignLibModDefFile flib)) = unsupported [ - "Module definition file not supported on Linux" - ] - | not (null (foreignLibVersionInfo flib)) - && not (null (foreignLibVersionLinux flib)) = unsupported [ - "You must not specify both lib-version-info and lib-version-linux" - ] - | otherwise = - Nothing - goGhcLinux _ = unsupported [ - "We can currently only build shared foreign libraries on Linux" - ] - - goGhcWindows :: ForeignLibType -> Maybe String - goGhcWindows ForeignLibNativeShared - | not standalone = unsupported [ - "We can currently only build standalone libraries on Windows. Use\n" - , " if os(Windows)\n" - , " options: standalone\n" - , "in your foreign-library stanza." - ] - | not (null (foreignLibVersionInfo flib)) = unsupported [ - "Foreign library versioning not currently supported on Windows.\n" - , "You can specify module definition files in the mod-def-file field." - ] - | otherwise = - Nothing - goGhcWindows _ = unsupported [ - "We can currently only build shared foreign libraries on Windows" - ] +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. +module Distribution.Simple.Configure + ( configure + , configure_setupHooks + , writePersistBuildConfig + , getConfigStateFile + , getPersistBuildConfig + , checkPersistBuildConfigOutdated + , tryGetPersistBuildConfig + , maybeGetPersistBuildConfig + , findDistPref + , findDistPrefOrDefault + , getInternalLibraries + , computeComponentId + , computeCompatPackageKey + , localBuildInfoFile + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getInstalledPackagesById + , getPackageDBContents + , configCompiler + , configCompilerEx + , configCompilerAuxEx + , configCompilerProgDb + , computeEffectiveProfiling + , ccLdOptionsBuildInfo + , checkForeignDeps + , interpretPackageDbFlags + , ConfigStateFileError (..) + , tryGetConfigStateFile + , platformDefines + ) where + +import Control.Monad +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack.Configure +import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour) +import Distribution.Backpack.DescribeUnitId +import Distribution.Backpack.Id +import Distribution.Backpack.PreExistingComponent +import qualified Distribution.Compat.Graph as Graph +import Distribution.Compat.Stack +import Distribution.Compiler +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Check hiding (doesFileExist) +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.PrettyPrint +import Distribution.Simple.BuildTarget +import Distribution.Simple.BuildToolDepends +import Distribution.Simple.BuildWay +import Distribution.Simple.Compiler +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex, lookupUnitId) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.Db + ( ProgramDb (..) + , lookupProgramByName + , modifyProgramSearchPath + , prependProgramSearchPath + , updateConfiguredProgs + ) +import Distribution.Simple.Setup.Common as Setup +import Distribution.Simple.Setup.Config as Setup +import Distribution.Simple.SetupHooks.Internal + ( ConfigureHooks (..) + , applyComponentDiffs + , noConfigureHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentRequestedSpec +import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..)) +import Distribution.Types.GivenComponent +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.LocalBuildInfo +import Distribution.Types.MissingDependencyReason (MissingDependencyReason (..)) +import Distribution.Types.PackageVersionConstraint +import Distribution.Utils.LogProgress +import Distribution.Utils.NubList +import Distribution.Utils.String (trim) +import Distribution.Verbosity +import Distribution.Version + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS +import qualified Distribution.Simple.UHC as UHC + +import Control.Exception + ( try + ) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.List + ( intersect + , stripPrefix + , (\\) + ) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Distribution.Compat.Directory + ( doesPathExist + , listDirectory + ) +import Distribution.Compat.Environment (lookupEnv) +import Distribution.Parsec + ( simpleParsec + ) +import Distribution.Pretty + ( defaultStyle + , pretty + , prettyShow + ) +import Distribution.Simple.Errors +import Distribution.Types.AnnotatedId +import Distribution.Utils.Path +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , removeFile + ) +import System.FilePath + ( isAbsolute + ) +import System.IO + ( hClose + , hPutStrLn + ) +import qualified System.Info + ( compilerName + , compilerVersion + ) +import Text.PrettyPrint + ( Doc + , char + , hsep + , quotes + , renderStyle + , text + , ($+$) + ) + +import qualified Data.Maybe as M +import qualified Data.Set as Set +import qualified Distribution.Compat.NonEmptySet as NES + +type UseExternalInternalDeps = Bool + +-- | The errors that can be thrown when reading the @setup-config@ file. +data ConfigStateFileError + = -- | No header found. + ConfigStateFileNoHeader + | -- | Incorrect header. + ConfigStateFileBadHeader + | -- | Cannot parse file contents. + ConfigStateFileNoParse + | -- | No file! + ConfigStateFileMissing + { cfgStateFileErrorCwd :: Maybe (SymbolicPath CWD (Dir Pkg)) + , cfgStateFileErrorFile :: SymbolicPath Pkg File + } + | -- | Mismatched version. + ConfigStateFileBadVersion + PackageIdentifier + PackageIdentifier + (Either ConfigStateFileError LocalBuildInfo) + +-- | Format a 'ConfigStateFileError' as a user-facing error message. +dispConfigStateFileError :: ConfigStateFileError -> Doc +dispConfigStateFileError ConfigStateFileNoHeader = + text "Saved package config file header is missing." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileBadHeader = + text "Saved package config file header is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileNoParse = + text "Saved package config file is corrupt." + <+> text "Re-run the 'Setup configure' command." +dispConfigStateFileError ConfigStateFileMissing{} = + text "Run the 'Setup configure' command first." +dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) = + text "Saved package config file is outdated:" + $+$ badCabal + $+$ badCompiler + $+$ text "Re-run the 'Setup configure' command." + where + badCabal = + text "• the Cabal version changed from" + <+> pretty oldCabal + <+> "to" + <+> pretty currentCabalId + badCompiler + | oldCompiler == currentCompilerId = mempty + | otherwise = + text "• the compiler changed from" + <+> pretty oldCompiler + <+> "to" + <+> pretty currentCompilerId + +instance Show ConfigStateFileError where + show = renderStyle defaultStyle . dispConfigStateFileError + +instance Exception ConfigStateFileError + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO LocalBuildInfo +getConfigStateFile mbWorkDir setupConfigFile = do + let filename = interpretSymbolicPath mbWorkDir setupConfigFile + exists <- doesFileExist filename + unless exists $ throwIO $ ConfigStateFileMissing mbWorkDir setupConfigFile + -- Read the config file into a strict ByteString to avoid problems with + -- lazy I/O, then convert to lazy because the binary package needs that. + contents <- BS.readFile filename + let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents]) + + (cabalId, compId) <- parseHeader header + + let getStoredValue = do + result <- structuredDecodeOrFailIO (BLC8.tail body) + case result of + Left _ -> throwIO ConfigStateFileNoParse + Right x -> return x + deferErrorIfBadVersion act + | cabalId /= currentCabalId = do + eResult <- try act + throwIO $ ConfigStateFileBadVersion cabalId compId eResult + | otherwise = act + deferErrorIfBadVersion getStoredValue + where + _ = callStack -- TODO: attach call stack to exception + +-- | Read the 'localBuildInfoFile', returning either an error or the local build +-- info. +tryGetConfigStateFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg File + -- ^ The file path of the @setup-config@ file. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetConfigStateFile mbWorkDir = try . getConfigStateFile mbWorkDir + +-- | Try to read the 'localBuildInfoFile'. +tryGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Either ConfigStateFileError LocalBuildInfo) +tryGetPersistBuildConfig mbWorkDir = try . getPersistBuildConfig mbWorkDir + +-- | Read the 'localBuildInfoFile'. Throw an exception if the file is +-- missing, if the file cannot be read, or if the file was created by an older +-- version of Cabal. +getPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO LocalBuildInfo +getPersistBuildConfig mbWorkDir distPref = + getConfigStateFile mbWorkDir $ localBuildInfoFile distPref + +-- | Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory. + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig mbWorkDir = + liftM (either (const Nothing) Just) . tryGetPersistBuildConfig mbWorkDir + +-- | After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> LocalBuildInfo + -- ^ The 'LocalBuildInfo' to write. + -> IO () +writePersistBuildConfig mbWorkDir distPref lbi = do + createDirectoryIfMissing False (i distPref) + writeFileAtomic (i $ localBuildInfoFile distPref) $ + BLC8.unlines [showHeader pkgId, structuredEncode lbi] + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + pkgId = localPackage lbi + +-- | Identifier of the current Cabal package. +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion + +-- | Identifier of the current compiler package. +currentCompilerId :: PackageIdentifier +currentCompilerId = + PackageIdentifier + (mkPackageName System.Info.compilerName) + (mkVersion' System.Info.compilerVersion) + +-- | Parse the @setup-config@ file header, returning the package identifiers +-- for Cabal and the compiler. +parseHeader + :: ByteString + -- ^ The file contents. + -> IO (PackageIdentifier, PackageIdentifier) +parseHeader header = case BLC8.words header of + [ "Saved" + , "package" + , "config" + , "for" + , pkgId + , "written" + , "by" + , cabalId + , "using" + , compId + ] -> + maybe (throwIO ConfigStateFileBadHeader) return $ do + _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier + cabalId' <- simpleParsec (BLC8.unpack cabalId) + compId' <- simpleParsec (BLC8.unpack compId) + return (cabalId', compId') + _ -> throwIO ConfigStateFileNoHeader + +-- | Generate the @setup-config@ file header. +showHeader + :: PackageIdentifier + -- ^ The processed package. + -> ByteString +showHeader pkgId = + BLC8.unwords + [ "Saved" + , "package" + , "config" + , "for" + , toUTF8LBS $ prettyShow pkgId + , "written" + , "by" + , BLC8.pack $ prettyShow currentCabalId + , "using" + , BLC8.pack $ prettyShow currentCompilerId + ] + +-- | Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Dist) + -> SymbolicPath Pkg File + -> IO Bool +checkPersistBuildConfigOutdated mbWorkDir distPref pkg_descr_file = + i pkg_descr_file `moreRecentFile` i (localBuildInfoFile distPref) + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +-- | Get the path of @dist\/setup-config@. +localBuildInfoFile + :: SymbolicPath Pkg (Dir Dist) + -- ^ The @dist@ directory path. + -> SymbolicPath Pkg File +localBuildInfoFile distPref = distPref makeRelativePathEx "setup-config" + +-- ----------------------------------------------------------------------------- + +-- * Configuration + +-- ----------------------------------------------------------------------------- + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or the default prefix. +findDistPref + :: SymbolicPath Pkg (Dir Dist) + -- ^ default \"dist\" prefix + -> Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPref defDistPref overrideDistPref = do + envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR") + return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref) + where + parseEnvDistPref env = + case env of + Just distPref | not (null distPref) -> toFlag $ makeSymbolicPath distPref + _ -> NoFlag + +-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken +-- from (in order of highest to lowest preference) the override prefix, the +-- \"CABAL_BUILDDIR\" environment variable, or 'defaultDistPref' is used. Call +-- this function to resolve a @*DistPref@ flag whenever it is not known to be +-- set. (The @*DistPref@ flags are always set to a definite value before +-- invoking 'UserHooks'.) +findDistPrefOrDefault + :: Setup.Flag (SymbolicPath Pkg (Dir Dist)) + -- ^ override \"dist\" prefix + -> IO (SymbolicPath Pkg (Dir Dist)) +findDistPrefOrDefault = findDistPref defaultDistPref + +-- | Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure = configure_setupHooks noConfigureHooks + +configure_setupHooks + :: ConfigureHooks + -> (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo +configure_setupHooks + (ConfigureHooks{preConfPackageHook, postConfPackageHook, preConfComponentHook}) + (g_pkg_descr, hookedBuildInfo) + cfg = do + -- Cabal pre-configure + let verbosity = fromFlag (configVerbosity cfg) + distPref = fromFlag $ configDistPref cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + (lbc0, comp, platform, enabledComps) <- preConfigurePackage cfg g_pkg_descr + + -- Package-wide pre-configure hook + lbc1 <- + case preConfPackageHook of + Nothing -> return lbc0 + Just pre_conf -> do + let programDb0 = LBC.withPrograms lbc0 + programDb0' = programDb0{unconfiguredProgs = Map.empty} + input = + SetupHooks.PreConfPackageInputs + { SetupHooks.configFlags = cfg + , SetupHooks.localBuildConfig = lbc0{LBC.withPrograms = programDb0'} + , -- Unconfigured programs are not supplied to the hook, + -- as these cannot be passed over a serialisation boundary + -- (see the "Binary ProgramDb" instance). + SetupHooks.compiler = comp + , SetupHooks.platform = platform + } + SetupHooks.PreConfPackageOutputs + { SetupHooks.buildOptions = opts1 + , SetupHooks.extraConfiguredProgs = progs1 + } <- + pre_conf input + -- The package-wide pre-configure hook returns BuildOptions that + -- overrides the one it was passed in, as well as an update to + -- the ProgramDb in the form of new configured programs to add + -- to the program database. + return $ + lbc0 + { LBC.withBuildOptions = opts1 + , LBC.withPrograms = + updateConfiguredProgs + (`Map.union` progs1) + programDb0 + } + + -- Cabal package-wide configure + (lbc2, pbd2, pkg_info) <- + finalizeAndConfigurePackage cfg lbc1 g_pkg_descr comp platform enabledComps + + -- Package-wide post-configure hook + for_ postConfPackageHook $ \postConfPkg -> do + let input = + SetupHooks.PostConfPackageInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + } + postConfPkg input + + -- Per-component pre-configure hook + pkg_descr <- do + let pkg_descr2 = LBC.localPkgDescr pbd2 + applyComponentDiffs + verbosity + ( \c -> for preConfComponentHook $ \computeDiff -> do + let input = + SetupHooks.PreConfComponentInputs + { SetupHooks.localBuildConfig = lbc2 + , SetupHooks.packageBuildDescr = pbd2 + , SetupHooks.component = c + } + SetupHooks.PreConfComponentOutputs + { SetupHooks.componentDiff = diff + } <- + computeDiff input + return diff + ) + pkg_descr2 + let pbd3 = pbd2{LBC.localPkgDescr = pkg_descr} + + -- Cabal per-component configure + externalPkgDeps <- finalCheckPackage g_pkg_descr pbd3 hookedBuildInfo pkg_info + lbi <- configureComponents lbc2 pbd3 pkg_info externalPkgDeps + + writePersistBuildConfig mbWorkDir distPref lbi + + return lbi + +preConfigurePackage + :: ConfigFlags + -> GenericPackageDescription + -> IO (LBC.LocalBuildConfig, Compiler, Platform, ComponentRequestedSpec) +preConfigurePackage cfg g_pkg_descr = do + let verbosity = fromFlag $ configVerbosity cfg + + -- Determine the component we are configuring, if a user specified + -- one on the command line. We use a fake, flattened version of + -- the package since at this point, we're not really sure what + -- components we *can* configure. @Nothing@ means that we should + -- configure everything (the old behavior). + (mb_cname :: Maybe ComponentName) <- do + let flat_pkg_descr = flattenPackageDescription g_pkg_descr + targets0 = configTargets cfg + targets <- readBuildTargets verbosity flat_pkg_descr targets0 + -- TODO: bleat if you use the module/file syntax + let targets' = [cname | BuildTargetComponent cname <- targets] + case targets' of + _ | null targets0 -> return Nothing + [cname] -> return (Just cname) + [] -> dieWithException verbosity NoValidComponent + _ -> dieWithException verbosity ConfigureEitherSingleOrAll + + case mb_cname of + Nothing -> setupMessage verbosity "Configuring" (packageId g_pkg_descr) + Just cname -> + setupMessage' + verbosity + "Configuring" + (packageId g_pkg_descr) + cname + (Just (configInstantiateWith cfg)) + + -- configCID is only valid for per-component configure + when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $ + dieWithException verbosity ConfigCIDValidForPreComponent + + -- Make a data structure describing what components are enabled. + let enabled :: ComponentRequestedSpec + enabled = case mb_cname of + Just cname -> OneComponentRequestedSpec cname + Nothing -> + ComponentRequestedSpec + { -- The flag name (@--enable-tests@) is a + -- little bit of a misnomer, because + -- just passing this flag won't + -- "enable", in our internal + -- nomenclature; it's just a request; a + -- @buildable: False@ might make it + -- not possible to enable. + testsRequested = fromFlag (configTests cfg) + , benchmarksRequested = + fromFlag (configBenchmarks cfg) + } + -- Some sanity checks related to enabling components. + when + ( isJust mb_cname + && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg)) + ) + $ dieWithException verbosity SanityCheckForEnableComponents + + checkDeprecatedFlags verbosity cfg + checkExactConfiguration verbosity g_pkg_descr cfg + + programDbPre <- mkProgramDb cfg (configPrograms cfg) + -- comp: the compiler we're building with + -- compPlatform: the platform we're building for + -- programDb: location and args of all programs we're + -- building with + ( comp :: Compiler + , compPlatform :: Platform + , programDb00 :: ProgramDb + ) <- + configCompilerEx + (flagToMaybe (configHcFlavor cfg)) + (flagToMaybe (configHcPath cfg)) + (flagToMaybe (configHcPkg cfg)) + programDbPre + (lessVerbose verbosity) + + -- Where to build the package + let builddir :: SymbolicPath Pkg (Dir Build) -- e.g. dist/build + builddir = setupFlagsBuildDir $ configCommonFlags cfg + mbWorkDir = flagToMaybe $ configWorkingDir cfg + -- NB: create this directory now so that all configure hooks get + -- to see it. (In practice, the Configure build-type needs it before + -- the postConfPackageHook runs.) + createDirectoryIfMissingVerbose (lessVerbose verbosity) True $ + interpretSymbolicPath mbWorkDir builddir + + lbc <- computeLocalBuildConfig cfg comp programDb00 + return (lbc, comp, compPlatform, enabled) + +computeLocalBuildConfig + :: ConfigFlags + -> Compiler + -> ProgramDb + -> IO LBC.LocalBuildConfig +computeLocalBuildConfig cfg comp programDb = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + -- Decide if we're going to compile with split sections. + split_sections :: Bool <- + if not (fromFlag $ configSplitSections cfg) + then return False + else case compilerFlavor comp of + GHC + | compilerVersion comp >= mkVersion [8, 0] -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-sections; ignoring" + ) + return False + + -- Decide if we're going to compile with split objects. + split_objs :: Bool <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case compilerFlavor comp of + _ | split_sections -> + do + warn + verbosity + ( "--enable-split-sections and " + ++ "--enable-split-objs are mutually " + ++ "exclusive; ignoring the latter" + ) + return False + GHC -> + return True + GHCJS -> + return True + _ -> do + warn + verbosity + ( "this compiler does not support " + ++ "--enable-split-objs; ignoring" + ) + return False + + -- Basically yes/no/unknown. + let linkerSupportsRelocations :: Maybe Bool + linkerSupportsRelocations = + case lookupProgramByName "ld" programDb of + Nothing -> Nothing + Just ld -> + case Map.lookup "Supports relocatable output" $ programProperties ld of + Just "YES" -> Just True + Just "NO" -> Just False + _other -> Nothing + let ghciLibByDefault = + case compilerId comp of + CompilerId GHC _ -> + -- If ghc is non-dynamic, then ghci needs object files, + -- so we build one by default. + -- + -- Technically, archive files should be sufficient for ghci, + -- but because of GHC bug #8942, it has never been safe to + -- rely on them. By the time that bug was fixed, ghci had + -- been changed to read shared libraries instead of archive + -- files (see next code block). + not (GHC.compilerBuildWay comp `elem` [DynWay, ProfDynWay]) + CompilerId GHCJS _ -> + not (GHCJS.isDynamic comp) + _ -> False + + withGHCiLib_ <- + case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of + -- NOTE: If linkerSupportsRelocations is Nothing this may still fail if the + -- linker does not support -r. + True | not (fromMaybe True linkerSupportsRelocations) -> do + warn verbosity $ + "--enable-library-for-ghci is not supported with the current" + ++ " linker; ignoring..." + return False + v -> return v + + let sharedLibsByDefault + | fromFlag (configDynExe cfg) = + -- build a shared library if dynamically-linked + -- executables are requested + True + | otherwise = case compilerId comp of + CompilerId GHC _ -> + -- if ghc is dynamic, then ghci needs a shared + -- library, so we build one by default. + GHC.compilerBuildWay comp == DynWay + CompilerId GHCJS _ -> + GHCJS.isDynamic comp + _ -> False + withSharedLib_ = + -- build shared libraries if required by GHC or by the + -- executable linking mode, but allow the user to force + -- building only static library archives with + -- --disable-shared. + fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg + + withStaticLib_ = + -- build a static library (all dependent libraries rolled + -- into a huge .a archive) via GHCs -staticlib flag. + fromFlagOrDefault False $ configStaticLib cfg + + withDynExe_ = fromFlag $ configDynExe cfg + + withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg + + setProfiling <- configureProfiling verbosity cfg comp + + setCoverage <- configureCoverage verbosity cfg comp + + -- Turn off library and executable stripping when `debug-info` is set + -- to anything other than zero. + let + strip_libexe s f = + let defaultStrip = fromFlagOrDefault True (f cfg) + in case fromFlag (configDebugInfo cfg) of + NoDebugInfo -> return defaultStrip + _ -> case f cfg of + Flag True -> do + warn verbosity $ + "Setting debug-info implies " + ++ s + ++ "-stripping: False" + return False + _ -> return False + + strip_lib <- strip_libexe "library" configStripLibs + strip_exe <- strip_libexe "executable" configStripExes + + let buildOptions = + setCoverage . setProfiling $ + LBC.BuildOptions + { withVanillaLib = fromFlag $ configVanillaLib cfg + , withSharedLib = withSharedLib_ + , withStaticLib = withStaticLib_ + , withDynExe = withDynExe_ + , withFullyStaticExe = withFullyStaticExe_ + , withProfLib = False + , withProfLibShared = False + , withProfLibDetail = ProfDetailNone + , withProfExe = False + , withProfExeDetail = ProfDetailNone + , withOptimization = fromFlag $ configOptimization cfg + , withDebugInfo = fromFlag $ configDebugInfo cfg + , withGHCiLib = withGHCiLib_ + , splitSections = split_sections + , splitObjs = split_objs + , stripExes = strip_exe + , stripLibs = strip_lib + , exeCoverage = False + , libCoverage = False + , relocatable = fromFlagOrDefault False $ configRelocatable cfg + } + + -- Dynamic executable, but no shared vanilla libraries + when (LBC.withDynExe buildOptions && not (LBC.withProfExe buildOptions) && not (LBC.withSharedLib buildOptions)) $ + warn verbosity $ + "Executables will use dynamic linking, but a shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + -- Profiled dynamic executable, but no shared profiling libraries + when (LBC.withDynExe buildOptions && LBC.withProfExe buildOptions && not (LBC.withProfLibShared buildOptions)) $ + warn verbosity $ + "Executables will use profiled dynamic linking, but a profiled shared library " + ++ "is not being built. Linking will fail if any executables " + ++ "depend on the library." + + return $ + LBC.LocalBuildConfig + { extraConfigArgs = [] -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + , withPrograms = programDb + , withBuildOptions = buildOptions + } + +data PackageInfo = PackageInfo + { internalPackageSet :: Set LibraryName + , promisedDepsSet :: Map (PackageName, ComponentName) PromisedComponent + , installedPackageSet :: InstalledPackageIndex + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + } + +configurePackage + :: ConfigFlags + -> LBC.LocalBuildConfig + -> PackageDescription + -> FlagAssignment + -> ComponentRequestedSpec + -> Compiler + -> Platform + -> ProgramDb + -> PackageDBStack + -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr) +configurePackage cfg lbc0 pkg_descr00 flags enabled comp platform programDb0 packageDbs = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + + -- add extra include/lib dirs as specified in cfg + pkg_descr0 = addExtraIncludeLibDirsFromConfigFlags pkg_descr00 cfg + -- TODO: it is not clear whether this adding these dirs is necessary + -- when we are directly stating from a PackageDescription (e.g. when + -- cabal-install has determined a PackageDescription, instead of rediscovering + -- when working with a GenericPackageDescription). + -- Could this function call be moved to the end of finalizeAndConfigurePackage + -- right before calling configurePackage? + + -- Configure certain external build tools, see below for which ones. + let requiredBuildTools + -- If --ignore-build-tools is set, no build tool is required: + | fromFlagOrDefault False $ configIgnoreBuildTools cfg = + [] + | otherwise = do + bi <- enabledBuildInfos pkg_descr0 enabled + -- First, we collect any tool dep that we know is external. This is, + -- in practice: + -- + -- 1. `build-tools` entries on the whitelist + -- + -- 2. `build-tool-depends` that aren't from the current package. + let externBuildToolDeps = + [ LegacyExeDependency (unUnqualComponentName eName) versionRange + | buildTool@(ExeDependency _ eName versionRange) <- + getAllToolDependencies pkg_descr0 bi + , not $ isInternal pkg_descr0 buildTool + ] + -- Second, we collect any build-tools entry we don't know how to + -- desugar. We'll never have any idea how to build them, so we just + -- hope they are already on the PATH. + let unknownBuildTools = + [ buildTool + | buildTool <- buildTools bi + , Nothing == desugarBuildTool pkg_descr0 buildTool + ] + externBuildToolDeps ++ unknownBuildTools + + programDb1 <- + configureAllKnownPrograms (lessVerbose verbosity) programDb0 + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr2, programDb2) <- + configurePkgconfigPackages verbosity pkg_descr0 programDb1 enabled + + let use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute installation directory templates, based on user + -- configuration. + -- + -- TODO: Move this into a helper function. + defaultDirs :: InstallDirTemplates <- + defaultInstallDirs' + use_external_internal_deps + (compilerFlavor comp) + (fromFlag (configUserInstall cfg)) + (hasLibs pkg_descr2) + let + installDirs = + combineInstallDirs + fromFlagOrDefault + defaultDirs + (configInstallDirs cfg) + lbc = lbc0{LBC.withPrograms = programDb2} + pbd = + LBC.PackageBuildDescr + { configFlags = cfg + , flagAssignment = flags + , componentEnabledSpec = enabled + , compiler = comp + , hostPlatform = platform + , localPkgDescr = pkg_descr2 + , installDirTemplates = installDirs + , withPackageDB = packageDbs + , pkgDescrFile = Nothing + , extraCoverageFor = [] + } + + debug verbosity $ + "Finalized package description:\n" + ++ showPackageDescription pkg_descr2 + + return (lbc, pbd) + +finalizeAndConfigurePackage + :: ConfigFlags + -> LBC.LocalBuildConfig + -> GenericPackageDescription + -> Compiler + -> Platform + -> ComponentRequestedSpec + -> IO (LBC.LocalBuildConfig, LBC.PackageBuildDescr, PackageInfo) +finalizeAndConfigurePackage cfg lbc0 g_pkg_descr comp platform enabled = do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + + let programDb0 = LBC.withPrograms lbc0 + -- What package database(s) to use + packageDbs :: PackageDBStack + packageDbs = + interpretPackageDbFlags + (fromFlag (configUserInstall cfg)) + (configPackageDBs cfg) + + -- The InstalledPackageIndex of all installed packages + installedPackageSet :: InstalledPackageIndex <- + getInstalledPackages + (lessVerbose verbosity) + comp + mbWorkDir + packageDbs + programDb0 + + -- The set of package names which are "shadowed" by internal + -- packages, and which component they map to + let internalPackageSet :: Set LibraryName + internalPackageSet = getInternalLibraries g_pkg_descr + + -- Some sanity checks related to dynamic/static linking. + when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $ + dieWithException verbosity SanityCheckForDynamicStaticLinking + + -- allConstraints: The set of all 'Dependency's we have. Used ONLY + -- to 'configureFinalizedPackage'. + -- requiredDepsMap: A map from 'PackageName' to the specifically + -- required 'InstalledPackageInfo', due to --dependency + -- + -- NB: These constraints are to be applied to ALL components of + -- a package. Thus, it's not an error if allConstraints contains + -- more constraints than is necessary for a component (another + -- component might need it.) + -- + -- NB: The fact that we bundle all the constraints together means + -- that is not possible to configure a test-suite to use one + -- version of a dependency, and the executable to use another. + ( allConstraints :: [PackageVersionConstraint] + , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo + ) <- + either (dieWithException verbosity) return $ + combinedConstraints + (configConstraints cfg) + (configDependencies cfg) + installedPackageSet + + let + promisedDepsSet = mkPromisedDepsSet (configPromisedDependencies cfg) + pkg_info = + PackageInfo + { internalPackageSet + , promisedDepsSet + , installedPackageSet + , requiredDepsMap + } + + -- pkg_descr: The resolved package description, that does not contain any + -- conditionals, because we have an assignment for + -- every flag, either picking them ourselves using a + -- simple naive algorithm, or having them be passed to + -- us by 'configConfigurationsFlags') + -- flags: The 'FlagAssignment' that the conditionals were + -- resolved with. + -- + -- NB: Why doesn't finalizing a package also tell us what the + -- dependencies are (e.g. when we run the naive algorithm, + -- we are checking if dependencies are satisfiable)? The + -- primary reason is that we may NOT have done any solving: + -- if the flags are all chosen for us, this step is a simple + -- matter of flattening according to that assignment. It's + -- cleaner to then configure the dependencies afterwards. + let use_external_internal_deps = case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + ( pkg_descr0 :: PackageDescription + , flags :: FlagAssignment + ) <- + configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + ( dependencySatisfiable + use_external_internal_deps + (fromFlagOrDefault False (configExactConfiguration cfg)) + (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg)) + (packageName g_pkg_descr) + installedPackageSet + internalPackageSet + promisedDepsSet + requiredDepsMap + ) + comp + platform + g_pkg_descr + + (lbc, pbd) <- + configurePackage + cfg + lbc0 + pkg_descr0 + flags + enabled + comp + platform + programDb0 + packageDbs + return (lbc, pbd, pkg_info) + +addExtraIncludeLibDirsFromConfigFlags + :: PackageDescription -> ConfigFlags -> PackageDescription +addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = + let extraBi = + mempty + { extraLibDirs = configExtraLibDirs cfg + , extraLibDirsStatic = configExtraLibDirsStatic cfg + , extraFrameworkDirs = configExtraFrameworkDirs cfg + , includeDirs = configExtraIncludeDirs cfg + } + modifyLib l = + l + { libBuildInfo = + libBuildInfo l + `mappend` extraBi + } + modifyExecutable e = + e + { buildInfo = + buildInfo e + `mappend` extraBi + } + modifyForeignLib f = + f + { foreignLibBuildInfo = + foreignLibBuildInfo f + `mappend` extraBi + } + modifyTestsuite t = + t + { testBuildInfo = + testBuildInfo t + `mappend` extraBi + } + modifyBenchmark b = + b + { benchmarkBuildInfo = + benchmarkBuildInfo b + `mappend` extraBi + } + in pkg_descr + { library = modifyLib `fmap` library pkg_descr + , subLibraries = modifyLib `map` subLibraries pkg_descr + , executables = modifyExecutable `map` executables pkg_descr + , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr + , testSuites = modifyTestsuite `map` testSuites pkg_descr + , benchmarks = modifyBenchmark `map` benchmarks pkg_descr + } + +finalCheckPackage + :: GenericPackageDescription + -> LBC.PackageBuildDescr + -> HookedBuildInfo + -> PackageInfo + -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) +finalCheckPackage + g_pkg_descr + ( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , hostPlatform = compPlatform + , componentEnabledSpec = enabled + } + ) + hookedBuildInfo + (PackageInfo{internalPackageSet, promisedDepsSet, installedPackageSet, requiredDepsMap}) = + do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + cabalFileDir = packageRoot common + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + checkCompilerProblems verbosity comp pkg_descr enabled + checkPackageProblems + verbosity + cabalFileDir + g_pkg_descr + (updatePackageDescription hookedBuildInfo pkg_descr) + -- NB: we apply the HookedBuildInfo to check it is valid, + -- but we don't propagate it. + -- Other UserHooks must separately return it again, and we + -- will re-apply it each time. + + -- Check languages and extensions + -- TODO: Move this into a helper function. + let langlist = + nub $ + catMaybes $ + map + defaultLanguage + (enabledBuildInfos pkg_descr enabled) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + dieWithException verbosity $ + UnsupportedLanguages (packageId g_pkg_descr) (compilerId comp) (map prettyShow langs) + let extlist = + nub $ + concatMap + allExtensions + (enabledBuildInfos pkg_descr enabled) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + dieWithException verbosity $ + UnsupportedLanguageExtension (packageId g_pkg_descr) (compilerId comp) (map prettyShow exts) + + -- Check foreign library build requirements + let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled] + let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs + when (not (null unsupportedFLibs)) $ + dieWithException verbosity $ + CantFindForeignLibraries unsupportedFLibs + + -- The list of 'InstalledPackageInfo' recording the selected + -- dependencies on external packages. + -- + -- Invariant: For any package name, there is at most one package + -- in externalPackageDeps which has that name. + -- + -- NB: The dependency selection is global over ALL components + -- in the package (similar to how allConstraints and + -- requiredDepsMap are global over all components). In particular, + -- if *any* component (post-flag resolution) has an unsatisfiable + -- dependency, we will fail. This can sometimes be undesirable + -- for users, see #1786 (benchmark conflicts with executable), + -- + -- In the presence of Backpack, these package dependencies are + -- NOT complete: they only ever include the INDEFINITE + -- dependencies. After we apply an instantiation, we'll get + -- definite references which constitute extra dependencies. + -- (Why not have cabal-install pass these in explicitly? + -- For one it's deterministic; for two, we need to associate + -- them with renamings which would require a far more complicated + -- input scheme than what we have today.) + configureDependencies + verbosity + use_external_internal_deps + internalPackageSet + promisedDepsSet + installedPackageSet + requiredDepsMap + pkg_descr + enabled + +configureComponents + :: LBC.LocalBuildConfig + -> LBC.PackageBuildDescr + -> PackageInfo + -> ([PreExistingComponent], [ConfiguredPromisedComponent]) + -> IO LocalBuildInfo +configureComponents + lbc@(LBC.LocalBuildConfig{withPrograms = programDb}) + pbd0@( LBC.PackageBuildDescr + { configFlags = cfg + , localPkgDescr = pkg_descr + , compiler = comp + , componentEnabledSpec = enabled + } + ) + (PackageInfo{promisedDepsSet, installedPackageSet}) + externalPkgDeps = + do + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + use_external_internal_deps = + case enabled of + OneComponentRequestedSpec{} -> True + ComponentRequestedSpec{} -> False + + -- Compute internal component graph + -- + -- The general idea is that we take a look at all the source level + -- components (which may build-depends on each other) and form a graph. + -- From there, we build a ComponentLocalBuildInfo for each of the + -- components, which lets us actually build each component. + ( buildComponents :: [ComponentLocalBuildInfo] + , packageDependsIndex :: InstalledPackageIndex + ) <- + runLogProgress verbosity $ + configureComponentLocalBuildInfos + verbosity + use_external_internal_deps + enabled + (fromFlagOrDefault False (configDeterministic cfg)) + (configIPID cfg) + (configCID cfg) + pkg_descr + externalPkgDeps + (configConfigurationsFlags cfg) + (configInstantiateWith cfg) + installedPackageSet + comp + + let buildComponentsMap = + foldl' + ( \m clbi -> + Map.insertWith + (++) + (componentLocalName clbi) + [clbi] + m + ) + Map.empty + buildComponents + + let cbd = + LBC.ComponentBuildDescr + { componentGraph = Graph.fromDistinctList buildComponents + , componentNameMap = buildComponentsMap + , promisedPkgs = promisedDepsSet + , installedPkgs = packageDependsIndex + } + + -- For whole-package configure, we determine the + -- extraCoverageFor of the main lib and sub libs here. + extraCoverageUnitIds = case enabled of + -- Whole package configure, add package libs + ComponentRequestedSpec{} -> mapMaybe mbCompUnitId buildComponents + -- Component configure, no need to do anything since + -- extra-coverage-for will be passed for all other components that + -- should be covered. + OneComponentRequestedSpec{} -> [] + mbCompUnitId LibComponentLocalBuildInfo{componentUnitId} = Just componentUnitId + mbCompUnitId _ = Nothing + + pbd = + pbd0 + { LBC.extraCoverageFor = extraCoverageUnitIds + } + + lbd = + LBC.LocalBuildDescr + { packageBuildDescr = pbd + , componentBuildDescr = cbd + } + + lbi = + NewLocalBuildInfo + { localBuildDescr = lbd + , localBuildConfig = lbc + } + + when (LBC.relocatable $ LBC.withBuildOptions lbc) $ + checkRelocatable verbosity pkg_descr lbi + + when (LBC.withDynExe $ LBC.withBuildOptions lbc) $ + checkSharedExes verbosity lbi + + -- TODO: This is not entirely correct, because the dirs may vary + -- across libraries/executables + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to + -- cabal configure, is only a hidden option. It allows packages + -- to be relocatable with their package database. This however + -- breaks when the Paths_* or other includes are used that + -- contain hard coded paths. This is still an open TODO. + -- + -- Allowing ${pkgroot} here, however requires less custom hooks + -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872 + unless + ( isAbsolute (prefix dirs) + || "${pkgroot}" `isPrefixOf` prefix dirs + ) + $ dieWithException verbosity + $ ExpectedAbsoluteDirectory (prefix dirs) + + when ("${pkgroot}" `isPrefixOf` prefix dirs) $ + warn verbosity $ + "Using ${pkgroot} in prefix " + ++ prefix dirs + ++ " will not work if you rely on the Path_* module " + ++ " or other hard coded paths. Cabal does not yet " + ++ " support fully relocatable builds! " + ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909" + ++ " #4097 #4291 #4872" + + info verbosity $ + "Using " + ++ prettyShow currentCabalId + ++ " compiled by " + ++ prettyShow currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where + relNote = case buildOS of + Windows + | not (hasLibs pkg_descr) + && isNothing isPrefixRelative -> + " (fixed location)" + _ -> "" + + dirinfo "Executables" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative) + dirinfo "Private executables" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative) + + sequence_ + [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programDb + ] + + return lbi + +mkPromisedDepsSet :: [PromisedComponent] -> Map (PackageName, ComponentName) PromisedComponent +mkPromisedDepsSet comps = Map.fromList [((packageName pn, CLibName ln), p) | p@(PromisedComponent pn ln _) <- comps] + +-- | Adds the extra program paths from the flags provided to @configure@ as +-- well as specified locations for certain known programs and their default +-- arguments. +mkProgramDb :: ConfigFlags -> ProgramDb -> IO ProgramDb +mkProgramDb cfg initialProgramDb = do + programDb <- + modifyProgramSearchPath (getProgramSearchPath initialProgramDb ++) -- We need to have the paths to programs installed by build-tool-depends before all other paths + <$> prependProgramSearchPath (fromFlagOrDefault normal (configVerbosity cfg)) searchpath [] initialProgramDb + pure + . userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ programDb + where + searchpath = fromNubList (configProgramPathExtra cfg) + +-- Note. We try as much as possible to _prepend_ rather than postpend the extra-prog-path +-- so that we can override the system path. However, in a v2-build, at this point, the "system" path +-- has already been extended by both the built-tools-depends paths, as well as the program-path-extra +-- so for v2 builds adding it again is entirely unnecessary. However, it needs to get added again _anyway_ +-- so as to take effect for v1 builds or standalone calls to Setup.hs +-- In this instance, the lesser evil is to not allow it to override the system path. + +-- ----------------------------------------------------------------------------- +-- Helper functions for configure + +-- | Check if the user used any deprecated flags. +checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO () +checkDeprecatedFlags verbosity cfg = do + unless (configProfExe cfg == NoFlag) $ do + let enable + | fromFlag (configProfExe cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-executable-profiling is deprecated. " + ++ "Please use --" + ++ enable + ++ "-profiling instead." + ) + + unless (configLibCoverage cfg == NoFlag) $ do + let enable + | fromFlag (configLibCoverage cfg) = "enable" + | otherwise = "disable" + warn + verbosity + ( "The flag --" + ++ enable + ++ "-library-coverage is deprecated. " + ++ "Please use --" + ++ enable + ++ "-coverage instead." + ) + +-- | Sanity check: if '--exact-configuration' was given, ensure that the +-- complete flag assignment was specified on the command line. +checkExactConfiguration + :: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO () +checkExactConfiguration verbosity pkg_descr0 cfg = + when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do + let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg)) + allFlags = map flagName . genPackageFlags $ pkg_descr0 + diffFlags = allFlags \\ cmdlineFlags + when (not . null $ diffFlags) $ + dieWithException verbosity $ + FlagsNotSpecified diffFlags + +-- | Create a PackageIndex that makes *any libraries that might be* +-- defined internally to this package look like installed packages, in +-- case an executable should refer to any of them as dependencies. +-- +-- It must be *any libraries that might be* defined rather than the +-- actual definitions, because these depend on conditionals in the .cabal +-- file, and we haven't resolved them yet. finalizePD +-- does the resolution of conditionals, and it takes internalPackageSet +-- as part of its input. +getInternalLibraries + :: GenericPackageDescription + -> Set LibraryName +getInternalLibraries pkg_descr0 = + -- TODO: some day, executables will be fair game here too! + let pkg_descr = flattenPackageDescription pkg_descr0 + in Set.fromList (map libName (allLibraries pkg_descr)) + +-- | Returns true if a dependency is satisfiable. This function may +-- report a dependency satisfiable even when it is not, but not vice +-- versa. This is to be passed to finalize +dependencySatisfiable + :: Bool + -- ^ use external internal deps? + -> Bool + -- ^ exact configuration? + -> Bool + -- ^ allow depending on private libs? + -> PackageName + -> InstalledPackageIndex + -- ^ installed set + -> Set LibraryName + -- ^ library components + -> Map (PackageName, ComponentName) PromisedComponent + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required dependencies + -> (Dependency -> DependencySatisfaction) +dependencySatisfiable + use_external_internal_deps + exact_config + allow_private_deps + pn + installedPackageSet + packageLibraries + promisedDeps + requiredDepsMap + (Dependency depName vr sublibs) + | exact_config = + -- When we're given '--exact-configuration', we assume that all + -- dependencies and flags are exactly specified on the command + -- line. Thus we only consult the 'requiredDepsMap'. Note that + -- we're not doing the version range check, so if there's some + -- dependency that wasn't specified on the command line, + -- 'finalizePD' will fail. + -- TODO: mention '--exact-configuration' in the error message + -- when this fails? + if isInternalDep && not use_external_internal_deps + then -- Except for internal deps, when we're NOT per-component mode; + -- those are just True. + internalDepSatisfiable + else -- Backward compatibility for the old sublibrary syntax + + let depComponentName = + CLibName $ LSubLibName $ packageNameToUnqualComponentName depName + invisibleLibraries = NES.filter (not . visible) sublibs + in if sublibs == mainLibSet && Map.member (pn, depComponentName) requiredDepsMap + then Satisfied + else case nonEmpty $ Set.toList invisibleLibraries of + Nothing -> Satisfied + Just invisibleLibraries' -> Unsatisfied $ MissingLibrary invisibleLibraries' + | isInternalDep = + if use_external_internal_deps + then -- When we are doing per-component configure, we now need to + -- test if the internal dependency is in the index. This has + -- DIFFERENT semantics from normal dependency satisfiability. + internalDepSatisfiableExternally + else -- If a 'PackageName' is defined by an internal component, the dep is + -- satisfiable (we're going to build it ourselves) + internalDepSatisfiable + | otherwise = + depSatisfiable + where + -- Internal dependency is when dependency is the same as package. + isInternalDep = pn == depName + + depSatisfiable = + let allVersions = PackageIndex.lookupPackageName installedPackageSet depName + eligibleVersions = + [ version + | (version, _infos) <- PackageIndex.eligibleDependencies allVersions + ] + in if null $ PackageIndex.matchingDependencies vr allVersions + then + if null eligibleVersions + then Unsatisfied $ MissingPackage + else Unsatisfied $ WrongVersion eligibleVersions + else Satisfied + + internalDepSatisfiable = + let missingLibraries = (NES.toSet sublibs) `Set.difference` packageLibraries + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + internalDepSatisfiableExternally = + -- TODO: Might need to propagate information on which versions _are_ available, if any... + let missingLibraries = + NES.filter (null . PackageIndex.lookupInternalDependency installedPackageSet pn vr) sublibs + in case nonEmpty $ Set.toList missingLibraries of + Nothing -> Satisfied + Just missingLibraries' -> Unsatisfied $ MissingLibrary missingLibraries' + + -- Check whether a library exists and is visible. + -- We don't disambiguate between dependency on non-existent or private + -- library yet, so we just return a bool and later report a generic error. + visible lib = + maybe + False -- Does not even exist (wasn't in the depsMap) + ( \ipi -> + IPI.libVisibility ipi == LibraryVisibilityPublic + -- If the override is enabled, the visibility does + -- not matter (it's handled externally) + || allow_private_deps + -- If it's a library of the same package then it's + -- always visible. + -- This is only triggered when passing a component + -- of the same package as --dependency, such as in: + -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs + || pkgName (IPI.sourcePackageId ipi) == pn + ) + maybeIPI + -- Don't check if it's visible, we promise to build it before we need it. + || promised + where + maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap + promised = isJust $ Map.lookup (depName, CLibName lib) promisedDeps + +-- | Finalize a generic package description. +-- +-- The workhorse is 'finalizePD'. +configureFinalizedPackage + :: Verbosity + -> ConfigFlags + -> ComponentRequestedSpec + -> [PackageVersionConstraint] + -> (Dependency -> DependencySatisfaction) + -- ^ tests if a dependency is satisfiable. + -- Might say it's satisfiable even when not. + -> Compiler + -> Platform + -> GenericPackageDescription + -> IO (PackageDescription, FlagAssignment) +configureFinalizedPackage + verbosity + cfg + enabled + allConstraints + satisfies + comp + compPlatform + pkg_descr0 = do + (pkg_descr, flags) <- + case finalizePD + (configConfigurationsFlags cfg) + enabled + satisfies + compPlatform + (compilerInfo comp) + allConstraints + pkg_descr0 of + Right r -> return r + Left missing -> + dieWithException verbosity $ EncounteredMissingDependency missing + + unless (nullFlagAssignment flags) $ + info verbosity $ + "Flags chosen: " + ++ intercalate + ", " + [ unFlagName fn ++ "=" ++ prettyShow value + | (fn, value) <- unFlagAssignment flags + ] + + return (pkg_descr, flags) + +-- | Check for use of Cabal features which require compiler support +checkCompilerProblems + :: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO () +checkCompilerProblems verbosity comp pkg_descr enabled = do + unless + ( renamingPackageFlagsSupported comp + || all + (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins) + (enabledBuildInfos pkg_descr enabled) + ) + $ dieWithException verbosity CompilerDoesn'tSupportThinning + when + ( any (not . null . reexportedModules) (allLibraries pkg_descr) + && not (reexportedModulesSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportReexports + when + ( any (not . null . signatures) (allLibraries pkg_descr) + && not (backpackSupported comp) + ) + $ dieWithException verbosity CompilerDoesn'tSupportBackpack + +-- | Select dependencies for the package. +configureDependencies + :: Verbosity + -> UseExternalInternalDeps + -> Set LibraryName + -> Map (PackageName, ComponentName) PromisedComponent + -> InstalledPackageIndex + -- ^ installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ required deps + -> PackageDescription + -> ComponentRequestedSpec + -> IO ([PreExistingComponent], [ConfiguredPromisedComponent]) +configureDependencies + verbosity + use_external_internal_deps + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + pkg_descr + enableSpec = do + let failedDeps :: [FailedDependency] + allPkgDeps :: [ResolvedDependency] + (failedDeps, allPkgDeps) = + partitionEithers $ + concat + [ fmap (\s -> (dep, s)) <$> status + | dep <- enabledBuildDepends pkg_descr enableSpec + , let status = + selectDependency + (package pkg_descr) + packageLibraries + promisedDeps + installedPackageSet + requiredDepsMap + use_external_internal_deps + dep + ] + + internalPkgDeps = + [ pkgid + | (_, InternalDependency pkgid) <- allPkgDeps + ] + -- NB: we have to SAVE the package name, because this is the only + -- way we can be able to resolve package names in the package + -- description. + externalPkgDeps = + [ pec + | (_, ExternalDependency pec) <- allPkgDeps + ] + + promisedPkgDeps = + [ fpec + | (_, PromisedDependency fpec) <- allPkgDeps + ] + + when + ( not (null internalPkgDeps) + && not (newPackageDepsBehaviour pkg_descr) + ) + $ dieWithException verbosity + $ LibraryWithinSamePackage internalPkgDeps + reportFailedDependencies verbosity failedDeps + reportSelectedDependencies verbosity allPkgDeps + + return (externalPkgDeps, promisedPkgDeps) + +-- | Select and apply coverage settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureCoverage + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureCoverage verbosity cfg comp = do + let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg) + tryLibCoverage = + fromFlagOrDefault + tryExeCoverage + (mappend (configCoverage cfg) (configLibCoverage cfg)) + -- TODO: Should we also enforce something here on that --coverage-for cannot + -- include indefinite components or instantiations? + if coverageSupported comp + then do + let apply buildOptions = + buildOptions + { LBC.libCoverage = tryLibCoverage + , LBC.exeCoverage = tryExeCoverage + } + return apply + else do + let apply buildOptions = + buildOptions + { LBC.libCoverage = False + , LBC.exeCoverage = False + } + when (tryExeCoverage || tryLibCoverage) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "program coverage. Program coverage has been disabled." + ) + return apply + +-- | Compute the effective value of the profiling flags +-- @--enable-library-profiling@ and @--enable-executable-profiling@ +-- from the specified 'ConfigFlags'. This may be useful for +-- external Cabal tools which need to interact with Setup in +-- a backwards-compatible way: the most predictable mechanism +-- for enabling profiling across many legacy versions is to +-- NOT use @--enable-profiling@ and use those two flags instead. +-- +-- Note that @--enable-executable-profiling@ also affects profiling +-- of benchmarks and (non-detailed) test suites. +computeEffectiveProfiling :: ConfigFlags -> (Bool {- lib vanilla-}, Bool {- lib shared -}, Bool {- exe -}) +computeEffectiveProfiling cfg = + -- The --profiling flag sets the default for both libs and exes, + -- but can be overridden by --library-profiling, or the old deprecated + -- --executable-profiling flag. + -- + -- The --profiling-detail and --library-profiling-detail flags behave + -- similarly + let dynamicExe = fromFlagOrDefault False (configDynExe cfg) + tryExeProfiling = + fromFlagOrDefault + False + (mappend (configProf cfg) (configProfExe cfg)) + tryLibProfiling = + fromFlagOrDefault + (tryExeProfiling && not dynamicExe) + (configProfLib cfg) + tryLibProfilingShared = + fromFlagOrDefault + (tryExeProfiling && dynamicExe) + (configProfShared cfg) + in (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) + +-- | Select and apply profiling settings for the build based on the +-- 'ConfigFlags' and 'Compiler'. +configureProfiling + :: Verbosity + -> ConfigFlags + -> Compiler + -> IO (LBC.BuildOptions -> LBC.BuildOptions) +configureProfiling verbosity cfg comp = do + let (tryLibProfiling, tryLibProfilingShared, tryExeProfiling) = computeEffectiveProfiling cfg + + tryExeProfileLevel = + fromFlagOrDefault + ProfDetailDefault + (configProfDetail cfg) + tryLibProfileLevel = + fromFlagOrDefault + ProfDetailDefault + ( mappend + (configProfDetail cfg) + (configProfLibDetail cfg) + ) + + checkProfileLevel (ProfDetailOther other) = do + warn + verbosity + ( "Unknown profiling detail level '" + ++ other + ++ "', using default.\nThe profiling detail levels are: " + ++ intercalate + ", " + [name | (name, _, _) <- knownProfDetailLevels] + ) + return ProfDetailDefault + checkProfileLevel other = return other + + applyProfiling <- + if profilingSupported comp && (profilingVanillaSupportedOrUnknown comp || profilingDynamicSupportedOrUnknown comp) + then do + exeLevel <- checkProfileLevel tryExeProfileLevel + libLevel <- checkProfileLevel tryLibProfileLevel + let apply buildOptions = + buildOptions + { LBC.withProfLib = tryLibProfiling + , LBC.withProfLibDetail = libLevel + , LBC.withProfExe = tryExeProfiling + , LBC.withProfExeDetail = exeLevel + } + let compilerSupportsProfilingDynamic = profilingDynamicSupportedOrUnknown comp + apply2 <- + if compilerSupportsProfilingDynamic + then -- Case 1: We support profiled shared libraries so turn on shared profiling + -- libraries if the user asked for it. + return $ \buildOptions -> apply buildOptions{LBC.withProfLibShared = tryLibProfilingShared} + else -- Case 2: Compiler doesn't support profiling shared so turn them off + do + -- If we wanted to enable profiling shared libraries.. tell the + -- user we couldn't. + when (profilingVanillaSupportedOrUnknown comp && tryLibProfilingShared) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling shared objects. Static profiled objects " + ++ "will be built." + ) + return $ \buildOptions -> + let original_options = apply buildOptions + in original_options + { LBC.withProfLibShared = False + , LBC.withProfLib = profilingVanillaSupportedOrUnknown comp && (tryLibProfilingShared || LBC.withProfLib original_options) + , LBC.withDynExe = if LBC.withProfExe original_options then False else LBC.withDynExe original_options + } + + when (tryExeProfiling && not (tryLibProfiling || tryLibProfilingShared)) $ do + warn + verbosity + ( "Executables will be built with profiling, but library " + ++ "profiling is disabled. Linking will fail if any executables " + ++ "depend on the library." + ) + return apply2 + else do + let apply buildOptions = + buildOptions + { LBC.withProfLib = False + , LBC.withProfLibShared = False + , LBC.withProfLibDetail = ProfDetailNone + , LBC.withProfExe = False + , LBC.withProfExeDetail = ProfDetailNone + } + when (tryExeProfiling || tryLibProfiling) $ + warn + verbosity + ( "The compiler " + ++ showCompilerId comp + ++ " does not support " + ++ "profiling. Profiling has been disabled." + ) + return apply + + return applyProfiling + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing = + info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) = + info verbosity $ "Using " ++ programName prog ++ version ++ location + where + location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ prettyShow v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +type ResolvedDependency = (Dependency, DependencyResolution) + +data DependencyResolution + = -- | An external dependency from the package database, OR an + -- internal dependency which we are getting from the package + -- database. + ExternalDependency PreExistingComponent + | -- | A promised dependency, which doesn't yet exist, but should be provided + -- at the build time. + -- + -- We have these such that we can configure components without actually + -- building its dependencies, if these dependencies need to be built later + -- again. For example, when launching a multi-repl, + -- we need to build packages in the interactive ghci session, no matter + -- whether they have been built before. + -- Building them in the configure phase is then redundant and costs time. + PromisedDependency ConfiguredPromisedComponent + | -- | An internal dependency ('PackageId' should be a library name) + -- which we are going to have to build. (The + -- 'PackageId' here is a hack to get a modest amount of + -- polymorphism out of the Pkg' typeclass.) + InternalDependency PackageId + +-- | Test for a package dependency and record the version we have installed. +selectDependency + :: PackageId + -- ^ Package id of current package + -> Set LibraryName + -- ^ package libraries + -> Map (PackageName, ComponentName) PromisedComponent + -- ^ Set of components that are promised, i.e. are not installed already. See 'PromisedDependency' for more details. + -> InstalledPackageIndex + -- ^ Installed packages + -> Map (PackageName, ComponentName) InstalledPackageInfo + -- ^ Packages for which we have been given specific deps to + -- use + -> UseExternalInternalDeps + -- ^ Are we configuring a + -- single component? + -> Dependency + -> [Either FailedDependency DependencyResolution] +selectDependency + pkgid + internalIndex + promisedIndex + installedIndex + requiredDepsMap + use_external_internal_deps + (Dependency dep_pkgname vr libs) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + if dep_pkgname == pn + then + if use_external_internal_deps + then do_external_internal <$> NES.toList libs + else do_internal <$> NES.toList libs + else do_external_external <$> NES.toList libs + where + pn = packageName pkgid + + -- It's an internal library, and we're not per-component build + do_internal lib + | Set.member lib internalIndex = + Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid + | otherwise = + Left $ DependencyMissingInternal dep_pkgname lib + + -- We have to look it up externally + do_external_external :: LibraryName -> Either FailedDependency DependencyResolution + do_external_external lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_external lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + -- Otherwise we just pick an arbitrary instance of the latest version. + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of + Nothing -> Left (DependencyNotExists dep_pkgname) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution + do_external_internal lib + | Just pc <- Map.lookup (dep_pkgname, CLibName lib) promisedIndex = + return $ PromisedDependency (ConfiguredPromisedComponent dep_pkgname (AnnotatedId (promisedComponentPackage pc) (CLibName lib) (promisedComponentId pc))) + do_external_internal lib = do + ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of + -- If we know the exact pkg to use, then use it. + Just pkginstance -> Right pkginstance + Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of + -- It's an internal library, being looked up externally + Nothing -> Left (DependencyMissingInternal dep_pkgname lib) + Just pkg -> Right pkg + return $ ExternalDependency $ ipiToPreExistingComponent ipi + + pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo + pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs + +reportSelectedDependencies + :: Verbosity + -> [ResolvedDependency] + -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ + unlines + [ "Dependency " + ++ prettyShow (simplifyDependency dep) + ++ ": using " + ++ prettyShow pkgid + | (dep, resolution) <- deps + , let pkgid = case resolution of + ExternalDependency pkg' -> packageId pkg' + InternalDependency pkgid' -> pkgid' + PromisedDependency promisedComp -> packageId promisedComp + ] + +reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO () +reportFailedDependencies _ [] = return () +reportFailedDependencies verbosity failed = + dieWithException verbosity $ ReportFailedDependencies failed hackageUrl + +-- | List all installed packages in the given package databases. +-- Non-existent package databases do not cause errors, they just get skipped +-- with a warning and treated as empty ones, since technically they do not +-- contain any package. +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -- ^ The stack of package databases. + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do + when (null packageDBs) $ + dieWithException verbosity NoPackageDatabaseSpecified + + info verbosity "Reading installed packages..." + -- do not check empty packagedbs (ghc-pkg would error out) + packageDBs' <- filterM packageDBExists packageDBs + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb + UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb + flv -> + dieWithException verbosity $ HowToFindInstalledPackages flv + where + packageDBExists (SpecificPackageDB path0) = do + let path = interpretSymbolicPath mbWorkDir path0 + exists <- doesPathExist path + unless exists $ + warn verbosity $ + "Package db " <> path <> " does not exist yet" + return exists + -- Checking the user and global package dbs is more complicated and needs + -- way more data. Also ghc-pkg won't error out unless the user/global + -- pkgdb is overridden with an empty one, so we just don't check for them. + packageDBExists UserPackageDB = pure True + packageDBExists GlobalPackageDB = pure True + +-- | Like 'getInstalledPackages', but for a single package DB. +-- +-- NB: Why isn't this always a fall through to 'getInstalledPackages'? +-- That is because 'getInstalledPackages' performs some sanity checks +-- on the package database stack in question. However, when sandboxes +-- are involved these sanity checks are not desirable. +getPackageDBContents + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getPackageDBContents verbosity mbWorkDir packageDB progdb + GHCJS -> GHCJS.getPackageDBContents verbosity mbWorkDir packageDB progdb + -- For other compilers, try to fall back on 'getInstalledPackages'. + _ -> getInstalledPackages verbosity comp mbWorkDir [packageDB] progdb + +-- | A set of files (or directories) that can be monitored to detect when +-- there might have been a change in the installed packages. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD ('Dir from)) + -> PackageDBStackS from + -> ProgramDb + -> Platform + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity comp mbWorkDir packageDBs progdb platform = + case compilerFlavor comp of + GHC -> + GHC.getInstalledPackagesMonitorFiles + verbosity + mbWorkDir + platform + progdb + packageDBs + other -> do + warn verbosity $ + "don't know how to find change monitoring files for " + ++ "the installed package databases for " + ++ prettyShow other + return [] + +-- | Looks up the 'InstalledPackageInfo' of the given 'UnitId's from the +-- 'PackageDBStack' in the 'LocalBuildInfo'. +getInstalledPackagesById + :: (Exception (VerboseException exception), Show exception, Typeable exception) + => Verbosity + -> LocalBuildInfo + -> (UnitId -> exception) + -- ^ Construct an exception that is thrown if a + -- unit-id is not found in the installed packages, + -- from the unit-id that is missing. + -> [UnitId] + -- ^ The unit ids to lookup in the installed packages + -> IO [InstalledPackageInfo] +getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPackageDB = pkgDb, withPrograms = progDb} mkException unitids = do + let mbWorkDir = mbWorkDirLBI lbi + ipindex <- getInstalledPackages verbosity comp mbWorkDir pkgDb progDb + mapM + ( \uid -> case lookupUnitId ipindex uid of + Nothing -> dieWithException verbosity (mkException uid) + Just ipkg -> return ipkg + ) + unitids + +-- | The user interface specifies the package dbs to use with a combination of +-- @--global@, @--user@ and @--package-db=global|user|clear|$file@. +-- This function combines the global/user flag and interprets the package-db +-- flag into a single package db stack. +interpretPackageDbFlags :: Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp +interpretPackageDbFlags userInstall specificDBs = + extra initialStack specificDBs + where + initialStack + | userInstall = [GlobalPackageDB, UserPackageDB] + | otherwise = [GlobalPackageDB] + + extra dbs' [] = dbs' + extra _ (Nothing : dbs) = extra [] dbs + extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs + +-- We are given both --constraint="foo < 2.0" style constraints and also +-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581". +-- +-- When finalising the package we have to take into account the specific +-- installed deps we've been given, and the finalise function expects +-- constraints, so we have to translate these deps into version constraints. +-- +-- But after finalising we then have to make sure we pick the right specific +-- deps in the end. So we still need to remember which installed packages to +-- pick. +combinedConstraints + :: [PackageVersionConstraint] + -> [GivenComponent] + -- ^ installed dependencies + -> InstalledPackageIndex + -> Either + CabalException + ( [PackageVersionConstraint] + , Map (PackageName, ComponentName) InstalledPackageInfo + ) +combinedConstraints constraints dependencies installedPackages = do + when (not (null badComponentIds)) $ + Left $ + CombinedConstraints (dispDependencies badComponentIds) + + -- TODO: we don't check that all dependencies are used! + + return (allConstraints, idConstraintMap) + where + allConstraints :: [PackageVersionConstraint] + allConstraints = + constraints + ++ [ thisPackageVersionConstraint (packageId pkg) + | (_, _, _, Just pkg) <- dependenciesPkgInfo + ] + + idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo + idConstraintMap = + Map.fromList + -- NB: do NOT use the packageName from + -- dependenciesPkgInfo! + [ ((pn, cname), pkg) + | (pn, cname, _, Just pkg) <- dependenciesPkgInfo + ] + + -- The dependencies along with the installed package info, if it exists + dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId, Maybe InstalledPackageInfo)] + dependenciesPkgInfo = + [ (pkgname, CLibName lname, cid, mpkg) + | GivenComponent pkgname lname cid <- dependencies + , let mpkg = + PackageIndex.lookupComponentId + installedPackages + cid + ] + + -- If we looked up a package specified by an installed package id + -- (i.e. someone has written a hash) and didn't find it then it's + -- an error. + badComponentIds = + [ (pkgname, cname, cid) + | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo + ] + + dispDependencies deps = + hsep + [ text "--dependency=" + <<>> quotes + ( pretty pkgname + <<>> case cname of + CLibName LMainLibName -> "" + CLibName (LSubLibName n) -> ":" <<>> pretty n + _ -> ":" <<>> pretty cname + <<>> char '=' + <<>> pretty cid + ) + | (pkgname, cname, cid) <- deps + ] + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms + :: Verbosity + -> [LegacyExeDependency] + -> ProgramDb + -> IO ProgramDb +configureRequiredPrograms verbosity deps progdb = + foldM (configureRequiredProgram verbosity) progdb deps + +-- | Configure a required program, ensuring that it exists in the PATH +-- (or where the user has specified the program must live) and making it +-- available for use via the 'ProgramDb' interface. If the program is +-- known (exists in the input 'ProgramDb'), we will make sure that the +-- program matches the required version; otherwise we will accept +-- any version of the program and assume that it is a simpleProgram. +configureRequiredProgram + :: Verbosity + -> ProgramDb + -> LegacyExeDependency + -> IO ProgramDb +configureRequiredProgram + verbosity + progdb + (LegacyExeDependency progName verRange) = + case lookupProgramByName progName progdb of + Just prog -> + -- If the program has already been configured, use it + -- (as long as the version is compatible). + -- + -- Not doing so means falling back to the "simpleProgram" path below, + -- which might fail if the program has custom logic to find a version + -- (such as hsc2hs). + let loc = locationPath $ programLocation prog + in case programVersion prog of + Nothing + | verRange == anyVersion -> + return progdb + | otherwise -> + dieWithException verbosity $! + UnknownVersionDb (programId prog) verRange loc + Just version + | withinRange version verRange -> + return progdb + | otherwise -> + dieWithException verbosity $! + BadVersionDb (programId prog) version verRange loc + Nothing -> + -- Otherwise, try to configure it as a 'simpleProgram' automatically + case lookupKnownProgram progName progdb of + Nothing -> + -- There's a bit of a story behind this line. In old versions + -- of Cabal, there were only internal build-tools dependencies. So the + -- behavior in this case was: + -- + -- - If a build-tool dependency was internal, don't do + -- any checking. + -- + -- - If it was external, call 'configureRequiredProgram' to + -- "configure" the executable. In particular, if + -- the program was not "known" (present in 'ProgramDb'), + -- then we would just error. This was fine, because + -- the only way a program could be executed from 'ProgramDb' + -- is if some library code from Cabal actually called it, + -- and the pre-existing Cabal code only calls known + -- programs from 'defaultProgramDb', and so if it + -- is calling something else, you have a Custom setup + -- script, and in that case you are expected to register + -- the program you want to call in the ProgramDb. + -- + -- OK, so that was fine, until I (ezyang, in 2016) refactored + -- Cabal to support per-component builds. In this case, what + -- was previously an internal build-tool dependency now became + -- an external one, and now previously "internal" dependencies + -- are now external. But these are permitted to exist even + -- when they are not previously configured (something that + -- can only occur by a Custom script.) + -- + -- So, I decided, "Fine, let's just accept these in any + -- case." Thus this line. The alternative would have been to + -- somehow detect when a build-tools dependency was "internal" (by + -- looking at the unflattened package description) but this + -- would also be incompatible with future work to support + -- external executable dependencies: we definitely cannot + -- assume they will be preinitialized in the 'ProgramDb'. + configureProgram verbosity (simpleProgram progName) progdb + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, progdb') <- requireProgram verbosity prog progdb + return progdb' + | otherwise -> do + (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb + return progdb' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages + :: Verbosity + -> PackageDescription + -> ProgramDb + -> ComponentRequestedSpec + -> IO (PackageDescription, ProgramDb) +configurePkgconfigPackages verbosity pkg_descr progdb enabled + | null allpkgs = return (pkg_descr, progdb) + | otherwise = do + (_, _, progdb') <- + requireProgramVersion + (lessVerbose verbosity) + pkgConfigProgram + (orLaterVersion $ mkVersion [0, 9, 0]) + progdb + traverse_ requirePkg allpkgs + mlib' <- traverse addPkgConfigBILib (library pkg_descr) + libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr) + exes' <- traverse addPkgConfigBIExe (executables pkg_descr) + tests' <- traverse addPkgConfigBITest (testSuites pkg_descr) + benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr) + let pkg_descr' = + pkg_descr + { library = mlib' + , subLibraries = libs' + , executables = exes' + , testSuites = tests' + , benchmarks = benches' + } + return (pkg_descr', progdb') + where + allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled) + pkgconfig = + getDbProgramOutput + (lessVerbose verbosity) + pkgConfigProgram + progdb + + requirePkg dep@(PkgconfigDependency pkgn range) = do + version <- + pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + `catchExit` (\_ -> dieWithException verbosity $ PkgConfigNotFound pkg versionRequirement) + let v = PkgconfigVersion (toUTF8BS $ trim version) + if not (withinPkgconfigVersionRange v range) + then dieWithException verbosity $ BadVersion pkg versionRequirement v + else info verbosity (depSatisfied v) + where + depSatisfied v = + "Dependency " + ++ prettyShow dep + ++ ": using version " + ++ prettyShow v + + versionRequirement + | isAnyPkgconfigVersion range = "" + | otherwise = " version " ++ prettyShow range + + pkg = unPkgconfigName pkgn + + -- Adds pkgconfig dependencies to the build info for a component + addPkgConfigBI compBI setCompBI comp = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (compBI comp)) + return $ setCompBI comp (compBI comp `mappend` bi) + + -- Adds pkgconfig dependencies to the build info for a library + addPkgConfigBILib = addPkgConfigBI libBuildInfo $ + \lib bi -> lib{libBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for an executable + addPkgConfigBIExe = addPkgConfigBI buildInfo $ + \exe bi -> exe{buildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a test suite + addPkgConfigBITest = addPkgConfigBI testBuildInfo $ + \test bi -> test{testBuildInfo = bi} + + -- Adds pkgconfig dependencies to the build info for a benchmark + addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $ + \bench bi -> bench{benchmarkBuildInfo = bi} + + pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- getDbProgramOutput verbosity prog progdb ["--cflags"] +-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"] +-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static)) +ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags ldflags_static = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static + (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static + in mempty + { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' + , extraLibs = map (drop 2) extraLibs' + , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs' + , extraLibsStatic = map (drop 2) extraLibsStatic' + , extraLibDirsStatic = map (makeSymbolicPath . drop 2) extraLibDirsStatic' + , ccOptions = cflags' + , ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAuxEx + :: ConfigFlags + -> IO (Compiler, Platform, ProgramDb) +configCompilerAuxEx cfg = do + programDb <- mkProgramDb cfg defaultProgramDb + let common = configCommonFlags cfg + verbosity = fromFlag $ setupVerbosity common + configCompilerEx + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programDb + verbosity + +-- | Configure the compiler and associated programs such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerEx + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompilerEx Nothing _ _ _ verbosity = dieWithException verbosity UnknownCompilerException +configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do + (comp, maybePlatform, programDb) <- case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg progdb + GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure the compiler ONLY. +configCompiler + :: Maybe CompilerFlavor + -> Maybe FilePath + -- ^ user-specified @hc@ path (optional) + -> ProgramDb + -> Verbosity + -> IO (Compiler, Platform, ProgramDb) +configCompiler mbFlavor hcPath progdb verbosity = do + (comp, maybePlatform, programDb) <- + case mbFlavor of + Nothing -> dieWithException verbosity UnknownCompilerException + Just hcFlavor -> + case hcFlavor of + GHC -> GHC.configureCompiler verbosity hcPath progdb + GHCJS -> GHCJS.configureCompiler verbosity hcPath progdb + UHC -> UHC.configure verbosity hcPath progdb + _ -> dieWithException verbosity UnknownCompilerException + return (comp, fromMaybe buildPlatform maybePlatform, programDb) + +-- | Configure programs associated to the compiler, such as @hc-pkg@, @haddock@ +-- and toolchain program such as @ar@, @ld@. +configCompilerProgDb + :: Verbosity + -> Compiler + -> ProgramDb + -- ^ program database containing the compiler + -> Maybe FilePath + -- ^ user-specified @hc-pkg@ path (optional) + -> IO ProgramDb +configCompilerProgDb verbosity comp hcProgDb hcPkgPath = do + case compilerFlavor comp of + GHC -> GHC.compilerProgramDb verbosity comp hcProgDb hcPkgPath + GHCJS -> GHCJS.compilerProgramDb verbosity comp hcProgDb hcPkgPath + _ -> return hcProgDb + +-- ----------------------------------------------------------------------------- +-- Testing C lib and header dependencies + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = + ifBuildsWith + allHeaders + (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + ( do + missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs + ) + where + allHeaders = collectField (fmap getSymbolicPath . includes) + allLibs = + collectField $ + if withFullyStaticExe lbi + then extraLibsStatic + else extraLibs + + ifBuildsWith headers args success failure = do + checkDuplicateHeaders + ok <- builds (makeProgram headers) args + if ok then success else failure + + -- Ensure that there is only one header with a given name + -- in either the generated (most likely by `configure`) + -- build directory (e.g. `dist/build`) or in the source directory. + -- + -- If it exists in both, we'll remove the one in the source + -- directory, as the generated should take precedence. + -- + -- C compilers like to prefer source local relative includes, + -- so the search paths provided to the compiler via -I are + -- ignored if the included file can be found relative to the + -- including file. As such we need to take drastic measures + -- and delete the offending file in the source directory. + checkDuplicateHeaders = do + let relIncDirs = filter (not . isAbsolute) (collectField (fmap getSymbolicPath . includeDirs)) + isHeader = isSuffixOf ".h" + genHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (i (buildDir lbi) dir) `catchIO` (\_ -> return []) + srcHeaders <- for relIncDirs $ \dir -> + fmap (dir ) . filter isHeader + <$> listDirectory (baseDir dir) `catchIO` (\_ -> return []) + let commonHeaders = concat genHeaders `intersect` concat srcHeaders + for_ commonHeaders $ \hdr -> do + warn verbosity $ + "Duplicate header found in " + ++ (getSymbolicPath (buildDir lbi) hdr) + ++ " and " + ++ (baseDir hdr) + ++ "; removing " + ++ (baseDir hdr) + removeFile (baseDir hdr) + + findOffendingHdr = + ifBuildsWith + allHeaders + ccArgs + (return Nothing) + (go . tail . NEL.inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs : hdrsInits) = + -- Try just preprocessing first + ifBuildsWith + hdrs + cppArgs + -- If that works, try compiling too + ( ifBuildsWith + hdrs + ccArgs + (go hdrsInits) + (return . fmap Right . safeLast $ hdrs) + ) + (return . fmap Left . safeLast $ hdrs) + + cppArgs = "-E" : commonCppArgs -- preprocess only + ccArgs = "-c" : commonCcArgs -- don't try to link + findMissingLibs = + ifBuildsWith + [] + (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + common = configCommonFlags $ configFlags lbi + baseDir = packageRoot common + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + mbWorkDir = mbWorkDirLBI lbi + + commonCppArgs = + platformDefines lbi + -- TODO: This is a massive hack, to work around the + -- fact that the test performed here should be + -- PER-component (c.f. the "I'm Feeling Lucky"; we + -- should NOT be glomming everything together.) + ++ ["-I" ++ i (buildDir lbi makeRelativePathEx "autogen")] + -- `configure' may generate headers in the build directory + ++ [ "-I" ++ i (buildDir lbi unsafeCoerceSymbolicPath dir) + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + -- we might also reference headers from the + -- packages directory. + ++ [ "-I" ++ baseDir getSymbolicPath dir + | dir <- mapMaybe symbolicPathRelative_maybe $ ordNub (collectField includeDirs) + ] + ++ [ "-I" ++ dir + | dir <- ordNub (collectField (fmap getSymbolicPath . includeDirs)) + , isAbsolute dir + ] + ++ ["-I" ++ baseDir] + ++ collectField cppOptions + ++ collectField ccOptions + ++ [ "-I" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- IPI.includeDirs dep + ] + -- dedupe include dirs of dependencies + -- to prevent quadratic blow-up + ] + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonCcArgs = + commonCppArgs + ++ collectField ccOptions + ++ [ opt + | dep <- deps + , opt <- IPI.ccOptions dep + ] + + commonLdArgs = + [ "-L" ++ getSymbolicPath dir + | dir <- + ordNub $ + collectField + ( if withFullyStaticExe lbi + then extraLibDirsStatic + else extraLibDirs + ) + ] + ++ collectField ldOptions + ++ [ "-L" ++ dir + | dir <- + ordNub + [ dir + | dep <- deps + , dir <- + if withFullyStaticExe lbi + then IPI.libraryDirsStatic dep + else IPI.libraryDirs dep + ] + ] + -- TODO: do we also need dependent packages' ld options? + makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs + + makeProgram hdrs = + unlines $ + ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs] + ++ ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = enabledBuildInfos pkg (componentEnabledSpec lbi) + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds :: String -> [ProgArg] -> IO Bool + builds program args = + withTempFileCwd ".c" $ \cName cHnd -> + withTempFileCwd "" $ \oNname oHnd -> + do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- + getDbProgramOutputCwd + verbosity + mbWorkDir + gccProgram + (withPrograms lbi) + (getSymbolicPath cName : "-o" : getSymbolicPath oNname : args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors _ _ + | isNothing . lookupProgram gccProgram . withPrograms $ lbi = + dieWithException verbosity NoWorkingGcc + explainErrors hdr libs = + dieWithException verbosity $ ExplainErrors hdr libs + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems + :: Verbosity + -> FilePath + -- ^ Path to the @.cabal@ file's directory + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity dir gpkg pkg = do + ioChecks <- checkPackageFiles verbosity pkg dir + let pureChecks = checkPackage gpkg + (errors, warnings) = + partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks) + if null errors + then traverse_ (warn verbosity) (map ppPackageCheck warnings) + else dieWithException verbosity $ CheckPackageProblems (map ppPackageCheck errors) + where + -- Classify error/warnings. Left: error, Right: warning. + classEW :: PackageCheck -> Maybe (Either PackageCheck PackageCheck) + classEW e@(PackageBuildImpossible _) = Just (Left e) + classEW w@(PackageBuildWarning _) = Just (Right w) + classEW (PackageDistSuspicious _) = Nothing + classEW (PackageDistSuspiciousWarn _) = Nothing + classEW (PackageDistInexcusable _) = Nothing + +-- | Perform checks if a shared executable can be built +checkSharedExes + :: Verbosity + -> LocalBuildInfo + -> IO () +checkSharedExes verbosity lbi = + when (os == Windows) $ + dieWithException verbosity $ + NoOSSupport os "shared executables" + where + (Platform _ os) = hostPlatform lbi + +-- | Preform checks if a relocatable build is allowed +checkRelocatable + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +checkRelocatable verbosity pkg lbi = + sequence_ + [ checkOS + , checkCompiler + , packagePrefixRelative + , depsPrefixRelative + ] + where + -- Check if the OS support relocatable builds. + -- + -- If you add new OS' to this list, and your OS supports dynamic libraries + -- and RPATH, make sure you add your OS to RPATH-support list of: + -- Distribution.Simple.GHC.getRPaths + checkOS = + unless (os `elem` [OSX, Linux]) $ + dieWithException verbosity $ + NoOSSupport os "relocatable builds" + where + (Platform _ os) = hostPlatform lbi + + -- Check if the Compiler support relocatable builds + checkCompiler = + unless (compilerFlavor comp `elem` [GHC]) $ + dieWithException verbosity $ + NoCompilerSupport (show comp) + where + comp = compiler lbi + + -- Check if all the install dirs are relative to same prefix + packagePrefixRelative = + unless (relativeInstallDirs installDirs) $ + dieWithException verbosity $ + InstallDirsNotPrefixRelative (installDirs) + where + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + relativeInstallDirs (InstallDirs{..}) = + all + isJust + ( fmap + (stripPrefix p) + [ bindir + , libdir + , dynlibdir + , libexecdir + , includedir + , datadir + , docdir + , mandir + , htmldir + , haddockdir + , sysconfdir + ] + ) + + -- Check if the library dirs of the dependencies that are in the package + -- database to which the package is installed are relative to the + -- prefix of the package + depsPrefixRelative = do + pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi)) + traverse_ (doCheck $ getSymbolicPath pkgr) ipkgs + where + doCheck pkgr ipkg + | maybe False (== pkgr) (IPI.pkgRoot ipkg) = + for_ (IPI.libraryDirs ipkg) $ \libdir -> do + -- When @prefix@ is not under @pkgroot@, + -- @shortRelativePath prefix pkgroot@ will return a path with + -- @..@s and following check will fail without @canonicalizePath@. + canonicalized <- canonicalizePath libdir + -- The @prefix@ itself must also be canonicalized because + -- canonicalizing @libdir@ may expand symlinks which would make + -- @prefix@ no longer being a prefix of @canonical libdir@, + -- while @canonical p@ could be a prefix of @canonical libdir@ + p' <- canonicalizePath p + unless (p' `isPrefixOf` canonicalized) $ + dieWithException verbosity $ + LibDirDepsPrefixNotRelative libdir p + | otherwise = + return () + -- NB: should be good enough to check this against the default + -- component ID, but if we wanted to be strictly correct we'd + -- check for each ComponentId. + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + p = prefix installDirs + ipkgs = PackageIndex.allPackages (installedPkgs lbi) + +-- ----------------------------------------------------------------------------- +-- Testing foreign library requirements + +unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String] +unsupportedForeignLibs comp platform = + mapMaybe (checkForeignLibSupported comp platform) + +checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String +checkForeignLibSupported comp platform flib = go (compilerFlavor comp) + where + go :: CompilerFlavor -> Maybe String + go GHC + | compilerVersion comp < mkVersion [7, 8] = + unsupported + [ "Building foreign libraries is only supported with GHC >= 7.8" + ] + | otherwise = goGhcPlatform platform + go _ = + unsupported + [ "Building foreign libraries is currently only supported with ghc" + ] + + goGhcPlatform :: Platform -> Maybe String + goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib) + goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform _ FreeBSD) = goGhcLinux (foreignLibType flib) + goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib) + goGhcPlatform _ = + unsupported + [ "Building foreign libraries is currently only supported on Mac OS, " + , "Linux and Windows" + ] + + goGhcOsx :: ForeignLibType -> Maybe String + goGhcOsx ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on OSX" + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on OSX" + ] + | otherwise = + Nothing + goGhcOsx _ = + unsupported + [ "We can currently only build shared foreign libraries on OSX" + ] + + goGhcLinux :: ForeignLibType -> Maybe String + goGhcLinux ForeignLibNativeShared + | not (null (foreignLibModDefFile flib)) = + unsupported + [ "Module definition file not supported on Linux" + ] + | not (null (foreignLibVersionInfo flib)) + && not (null (foreignLibVersionLinux flib)) = + unsupported + [ "You must not specify both lib-version-info and lib-version-linux" + ] + | otherwise = + Nothing + goGhcLinux _ = + unsupported + [ "We can currently only build shared foreign libraries on Linux" + ] + + goGhcWindows :: ForeignLibType -> Maybe String + goGhcWindows ForeignLibNativeShared + | not standalone = + unsupported + [ "We can currently only build standalone libraries on Windows. Use\n" + , " if os(Windows)\n" + , " options: standalone\n" + , "in your foreign-library stanza." + ] + | not (null (foreignLibVersionInfo flib)) = + unsupported + [ "Foreign library versioning not currently supported on Windows.\n" + , "You can specify module definition files in the mod-def-file field." + ] + | otherwise = + Nothing + goGhcWindows _ = + unsupported + [ "We can currently only build shared foreign libraries on Windows" + ] standalone :: Bool standalone = ForeignLibStandalone `elem` foreignLibOptions flib diff --git a/src/Distribution/Simple/ConfigureScript.hs b/src/Distribution/Simple/ConfigureScript.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/ConfigureScript.hs @@ -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") + ] diff --git a/src/Distribution/Simple/Errors.hs b/src/Distribution/Simple/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Errors.hs @@ -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 .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." diff --git a/src/Distribution/Simple/FileMonitor/Types.hs b/src/Distribution/Simple/FileMonitor/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/FileMonitor/Types.hs @@ -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 : ":\\")) diff --git a/src/Distribution/Simple/Flag.hs b/src/Distribution/Simple/Flag.hs --- a/src/Distribution/Simple/Flag.hs +++ b/src/Distribution/Simple/Flag.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Flag -- Copyright : Isaac Jones 2003-2004 @@ -16,117 +17,109 @@ -- for an explanation. -- -- Split off from "Distribution.Simple.Setup" to break import cycles. -module Distribution.Simple.Flag ( - Flag(..), - allFlags, - toFlag, - fromFlag, - fromFlagOrDefault, - flagElim, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..) ) where +module Distribution.Simple.Flag + ( Flag + , pattern Flag + , pattern NoFlag + , allFlags + , toFlag + , fromFlag + , fromFlagOrDefault + , flagElim + , flagToMaybe + , flagToList + , maybeToFlag + , mergeListFlag + , BooleanFlag (..) + ) where -import Prelude () +import Data.Monoid (Last (..)) import Distribution.Compat.Prelude hiding (get) import Distribution.Compat.Stack +import Prelude () -- ------------------------------------------------------------ + -- * Flag type + -- ------------------------------------------------------------ -- | All flags are monoids, they come in two flavours: -- -- 1. list flags eg -- --- > --ghc-option=foo --ghc-option=bar +-- > --ghc-option=foo --ghc-option=bar -- --- gives us all the values ["foo", "bar"] +-- gives us all the values ["foo", "bar"] -- -- 2. singular value flags, eg: -- --- > --enable-foo --disable-foo +-- > --enable-foo --disable-foo -- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. +-- gives us Just False +-- +-- So, this 'Flag' type is for the latter singular kind of flag. -- Its monoid instance gives us the behaviour where it starts out as -- 'NoFlag' and later flags override earlier ones. -- -data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable) - -instance Binary a => Binary (Flag a) -instance Structured a => Structured (Flag a) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Applicative Flag where - (Flag x) <*> y = x <$> y - NoFlag <*> _ = NoFlag - pure = Flag - -instance Monoid (Flag a) where - mempty = NoFlag - mappend = (<>) +-- Isomorphic to 'Maybe' a. +type Flag = Last -instance Semigroup (Flag a) where - _ <> f@(Flag _) = f - f <> NoFlag = f +pattern Flag :: a -> Last a +pattern Flag a = Last (Just a) -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound +pattern NoFlag :: Last a +pattern NoFlag = Last Nothing -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] +{-# COMPLETE Flag, NoFlag #-} +-- | Wraps a value in 'Flag'. toFlag :: a -> Flag a toFlag = Flag +-- | Extracts a value from a 'Flag', and throws an exception on 'NoFlag'. fromFlag :: WithCallStack (Flag a -> a) fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" +-- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'. fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def +fromFlagOrDefault def = fromMaybe def . getLast +-- | Converts a 'Flag' value to a 'Maybe' value. flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing +flagToMaybe = getLast --- | @since 3.4.0.0 +-- | Pushes a function through a 'Flag' value, and returns a default +-- if the 'Flag' value is 'NoFlag'. +-- +-- @since 3.4.0.0 flagElim :: b -> (a -> b) -> Flag a -> b -flagElim n _ NoFlag = n -flagElim _ f (Flag x) = f x +flagElim n f = maybe n f . getLast +-- | Converts a 'Flag' value to a list. flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] +flagToList = maybeToList . getLast +-- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'. allFlags :: [Flag Bool] -> Flag Bool -allFlags flags = if all (\f -> fromFlagOrDefault False f) flags - then Flag True - else NoFlag +allFlags flags = + if all (\f -> fromFlagOrDefault False f) flags + then Flag True + else NoFlag +-- | Converts a 'Maybe' value to a 'Flag' value. maybeToFlag :: Maybe a -> Flag a -maybeToFlag Nothing = NoFlag -maybeToFlag (Just x) = Flag x +maybeToFlag = Last +-- | Merge the elements of a list 'Flag' with another list 'Flag'. +mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] +mergeListFlag currentFlags v = + Flag $ concat (flagToList currentFlags ++ flagToList v) + -- | Types that represent boolean flags. class BooleanFlag a where - asBool :: a -> Bool + asBool :: a -> Bool instance BooleanFlag Bool where asBool = id diff --git a/src/Distribution/Simple/GHC.hs b/src/Distribution/Simple/GHC.hs --- a/src/Distribution/Simple/GHC.hs +++ b/src/Distribution/Simple/GHC.hs @@ -1,2088 +1,1166 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC --- Copyright : Isaac Jones 2003-2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a fairly large module. It contains most of the GHC-specific code for --- configuring, building and installing packages. It also exports a function --- for finding out what packages are already installed. Configuring involves --- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions --- this version of ghc supports and returning a 'Compiler' value. --- --- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out --- what packages are installed. --- --- Building is somewhat complex as there is quite a bit of information to take --- into account. We have to build libs and programs, possibly for profiling and --- shared libs. We have to support building libraries that will be usable by --- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files --- using ghc. Linking, especially for @split-objs@ is remarkably complex, --- partly because there tend to be 1,000's of @.o@ files and this can often be --- more than we can pass to the @ld@ or @ar@ programs in one go. --- --- Installing for libs and exes involves finding the right files and copying --- them to the right places. One of the more tricky things about this module is --- remembering the layout of files in the build directory (which is not --- explicitly documented) and thus what search dirs are used for various kinds --- of files. - -module Distribution.Simple.GHC ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getGhcAppDir, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.CabalSpecVersion -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import Distribution.Simple.Program.Builtin (runghcProgram) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Ar as Ar -import qualified Distribution.Simple.Program.Ld as Ld -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.Version -import Distribution.System -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList -import Distribution.Utils.Path -import Language.Haskell.Extension - -import Control.Monad (msum, forM_) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile, getDirectoryContents ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info -#ifndef mingw32_HOST_OS -import System.Posix (createSymbolicLink) -#endif /* mingw32_HOST_OS */ - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - - (ghcProg, ghcVersion, progdb1) <- - requireProgramVersion verbosity ghcProgram - (orLaterVersion (mkVersion [7,0,1])) - (userMaybeSpecifyPath "ghc" hcPath conf0) - let implInfo = ghcVersionImplInfo ghcVersion - - -- Cabal currently supports ghc >= 7.0.1 && < 9.4 - -- ... and the following odd development version - unless (ghcVersion < mkVersion [9,4]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.4): " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcPkgProg, ghcPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcPkgProgram { - programFindLocation = guessGhcPkgFromGhcPath ghcProg - } - anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) - - when (ghcVersion /= ghcPkgVersion) $ die' verbosity $ - "Version mismatch between ghc and ghc-pkg: " - ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " " - ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = guessHsc2hsFromGhcPath ghcProg - } - haddockProgram' = haddockProgram { - programFindLocation = guessHaddockFromGhcPath ghcProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcPath ghcProg - } - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcPath ghcProg - } - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - addKnownProgram runghcProgram' progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcProg - extensions0 <- Internal.getExtensions verbosity implInfo ghcProg - - ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg - let ghcInfoMap = Map.fromList ghcInfo - extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 - filterExt JavaScriptFFI $ - -- see 'filterExtTH' comment below - filterExtTH $ extensions0 - - -- starting with GHC 8.0, `TemplateHaskell` will be omitted from - -- `--supported-extensions` when it's not available. - -- for older GHCs we can use the "Have interpreter" property to - -- filter out `TemplateHaskell` - filterExtTH | ghcVersion < mkVersion [8] - , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap - = filterExt TemplateHaskell - | otherwise = id - - filterExt ext = filter ((/= EnableExtension ext) . fst) - - let comp = Compiler { - compilerId = CompilerId GHC ghcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcInfo - -- configure gcc and ld - progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3 - return (comp, compPlatform, progdb4) - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find --- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking --- for a versioned or unversioned ghc-pkg in the same dir, that is: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessToolFromGhcPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcPath tool ghcProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcVersioned dir suf = dir (toolname ++ "-ghc" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessNormal dir] - | otherwise = [guessGhcVersioned dir suf, - guessVersioned dir suf, - guessNormal dir] - -- order matters here, see https://github.com/haskell/cabal/issues/7390 - guesses = (if real_path == given_path - then [] - else mkGuesses real_dir real_suf) - ++ mkGuesses given_dir given_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding ghc-pkg, we try looking for both a versioned and unversioned --- ghc-pkg in the same dir, that is: --- --- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg-6.6.1(.exe) --- > /usr/local/bin/ghc-pkg(.exe) --- -guessGhcPkgFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding hsc2hs, we try looking for both a versioned and unversioned --- hsc2hs in the same dir, that is: --- --- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) --- > /usr/local/bin/hsc2hs-6.6.1(.exe) --- > /usr/local/bin/hsc2hs(.exe) --- -guessHsc2hsFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram - --- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a --- corresponding haddock, we try looking for both a versioned and unversioned --- haddock in the same dir, that is: --- --- > /usr/local/bin/haddock-ghc-6.6.1(.exe) --- > /usr/local/bin/haddock-6.6.1(.exe) --- > /usr/local/bin/haddock(.exe) --- -guessHaddockFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram - -guessHpcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram - -guessRunghcFromGhcPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram - - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg - where - version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack - -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity comp packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! hackRtsPackage index - - where - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_,[rts])] - -> PackageIndex.insert (removeMingwIncludeDir rts) index - _ -> index -- No (or multiple) ghc rts package is registered!! - -- Feh, whatever, the ghc test suite does some crazy stuff. - --- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a --- @PackageIndex@. Helper function used by 'getPackageDBContents' and --- 'getInstalledPackages'. -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! mconcat indices - - where - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - --- | Return the 'FilePath' to the GHC application data directory. --- --- @since 3.4.0.0 -getGhcAppDir :: IO FilePath -getGhcAppDir = getAppUserDataDirectory "ghc" - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB - :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getGhcAppDir - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcVersion - packageConfFileName = "package.conf.d" - ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO () -checkPackageDbStack verbosity comp = - if flagPackageConf implInfo - then checkPackageDbStackPre76 verbosity - else checkPackageDbStackPost76 verbosity - where implInfo = ghcVersionImplInfo (compilerVersion comp) - -checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPost76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPost76 verbosity rest - | GlobalPackageDB `elem` rest = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" -checkPackageDbStackPost76 _ _ = return () - -checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStackPre76 _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStackPre76 verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ - "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6," - ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStackPre76 verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - --- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This --- breaks when you want to use a different gcc, so we need to filter --- it out. -removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo -removeMingwIncludeDir pkg = - let ids = InstalledPackageInfo.includeDirs pkg - ids' = filter (not . ("mingw" `isSuffixOf`)) ids - in pkg { InstalledPackageInfo.includeDirs = ids' } - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb - - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - whenReplLib = when forRepl - replFlags = fromMaybe mempty mReplFlags - comp = compiler lbi - ghcVersion = compilerVersion comp - implInfo = getImplInfo comp - platform@(Platform _hostArch hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let runGhcProg = runGHC verbosity ghcProg comp platform - - let libBi = libBuildInfo lib - - let isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcDynamic - forceSharedLib = doingTH && isGhcDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeSources = fromNubListR $ mconcat - [ toNubListR (cSources libBi) - , toNubListR (cxxSources libBi) - , toNubListR (cmmSources libBi) - , toNubListR (asmSources libBi) - ] - cLikeObjs = map (`replaceExtension` objExtension) cLikeSources - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - vanillaOpts = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - - profOpts = vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions libBi - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs libBi, - ghcOptInputFiles = toNubListR - [libTargetDir x | x <- cLikeObjs] - } - replOpts = vanillaOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra vanillaOpts) - <> replFlags, - ghcOptNumJobs = mempty - } - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi)) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcProg profOpts) - - -- Build any C++ sources separately. - unless (not has_code || null (cxxSources libBi)) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - -- build any C sources - unless (not has_code || null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] - - -- build any ASM sources - unless (not has_code || null (asmSources libBi)) $ do - info verbosity "Building Assembler Sources..." - sequence_ - [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaAsmOpts = if isGhcDynamic - -- Dynamic GHC requires objects to be built - -- with -fPIC for REPL to work. See #2207. - then baseAsmOpts { ghcOptFPic = toFlag True } - else baseAsmOpts - profAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedAsmOpts = vanillaAsmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaAsmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded asmOpts = do - needsRecomp <- checkNeedsRecompilation filename asmOpts - when needsRecomp $ runGhcProg asmOpts - runGhcProgIfNeeded vanillaAsmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts) - | filename <- asmSources libBi] - - -- build any Cmm sources - unless (not has_code || null (cmmSources libBi)) $ do - info verbosity "Building C-- Sources..." - sequence_ - [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCmmOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCmmOpts { ghcOptFPic = toFlag True } - else baseCmmOpts - profCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCmmOpts = vanillaCmmOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCmmOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cmmOpts = do - needsRecomp <- checkNeedsRecompilation filename cmmOpts - when needsRecomp $ runGhcProg cmmOpts - runGhcProgIfNeeded vanillaCmmOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts) - | filename <- cmmSources libBi] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - whenReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - runGhcProg replOpts - - -- link: - when has_code . unless forRepl $ do - info verbosity "Linking..." - let cLikeProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) - cLikeSources - cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - cLikeSources - compiler_id = compilerId (compiler lbi) - vanillaLibFilePath = libTargetDir mkLibName uid - profileLibFilePath = libTargetDir mkProfLibName uid - sharedLibFilePath = libTargetDir - mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir - mkStaticLibName (hostPlatform lbi) compiler_id uid - ghciLibFilePath = libTargetDir Internal.mkGHCiLibName uid - ghciProfLibFilePath = libTargetDir Internal.mkGHCiProfLibName uid - libInstallPath = libdir $ - absoluteComponentInstallDirs - pkg_descr lbi uid NoCopyDest - sharedLibInstallPath = libInstallPath - mkSharedLibName (hostPlatform lbi) compiler_id uid - - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True - hProfObjs <- - if withProfLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cLikeObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (libTargetDir ) cLikeObjs - ++ stubObjs - profObjectFiles = - hProfObjs - ++ map (libTargetDir ) cLikeProfObjs - ++ stubProfObjs - dynamicObjectFiles = - hSharedObjs - ++ map (libTargetDir ) cLikeSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo - { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) - - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles - - whenSharedLib False $ - runGhcProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity comp packageDBs - (ghcProg, _) <- requireProgram verbosity ghcProgram progdb - runGHC verbosity ghcProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> - "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> - "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - if isHaskell main - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ - exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib - } - - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcProg comp platform - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cLikeObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo - ++ [ "-static" - | withFullyStaticExe lbi ] - -- Pass extra `ld-options` given - -- through to GHC's linker. - ++ maybe [] programOverrideArgs - (lookupProgram ldProgram (withPrograms lbi)), - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cLikeObjs ++ cxxObjs] - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName - (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - - where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - --- | Extracts a String representing a hash of the ABI of a built --- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcProg comp platform ghcArgs) - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi = - Internal.componentGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeTargetName (hostPlatform lbi) exe - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref exeName' exeFileName) - (dest <.> exeExtension (hostPlatform lbi)) - when (stripExes lbi) $ - Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi) - (dest <.> exeExtension (hostPlatform lbi)) - installBinary (binDir fixedExeBaseName) - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - -- TODO: Should we strip? (stripLibs lbi) - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - -- Now install appropriate symlinks if library is versioned - let (Platform _ os) = hostPlatform lbi - when (not (null (foreignLibVersion flib os))) $ do - when (os /= Linux) $ die' verbosity - -- It should be impossible to get here. - "Can't install foreign-library symlink on non-Linux OS" -#ifndef mingw32_HOST_OS - -- 'createSymbolicLink file1 file2' creates a symbolic link - -- named 'file2' which points to the file 'file1'. - -- Note that we do want a symlink to 'name' rather than - -- 'dst', because the symlink will be relative to the - -- directory it's created in. - -- Finally, we first create the symlinks in a temporary - -- directory and then rename to simulate 'ln --force'. - withTempDirectory verbosity dstDir nm $ \tmpDir -> do - let link1 = flibBuildName lbi flib - link2 = "lib" ++ nm <.> "so" - createSymbolicLink name (tmpDir link1) - renameFile (tmpDir link1) (dstDir link1) - createSymbolicLink name (tmpDir link2) - renameFile (tmpDir link2) (dstDir link2) - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib -#endif /* mingw32_HOST_OS */ - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do - -- copy .hi files over: - whenVanilla $ copyModuleFiles "hi" - whenProf $ copyModuleFiles "p_hi" - whenShared $ copyModuleFiles "dyn_hi" - - -- copy the built library files over: - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary - builtDir - targetDir - (mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName - (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - whenGHCi $ installOrdinary builtDir targetDir ghciLibName - whenProf $ do - installOrdinary builtDir targetDir profileLibName - whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName - whenShared $ if - -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. - -- See ghc issue #15837 and Cabal PR #5855. - | specVersion pkg < CabalSpecV3_0 -> do - sequence_ [ installShared builtDir dynlibTargetDir - (mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - | otherwise -> do - sequence_ [ installShared - builtDir - dynlibTargetDir - (mkGenericSharedLibName - platform - compiler_id - (getHSLibraryName uid ++ f)) - | f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - sequence_ [ do - files <- getDirectoryContents builtDir - let l' = mkGenericSharedBundledLibName - platform - compiler_id - l - forM_ files $ \ file -> - when (l' `isPrefixOf` file) $ do - isFile <- doesFileExist (builtDir file) - when isFile $ do - installShared - builtDir - dynlibTargetDir - file - | l <- extraBundledLibs (libBuildInfo lib) - ] - - where - builtDir = componentBuildDir lbi clbi - - install isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi) $ Strip.stripLib verbosity - platform (withPrograms lbi) dst - - installOrdinary = install False - installShared = install True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - profileLibName = mkProfLibName uid - ghciLibName = Internal.mkGHCiLibName uid - ghciProfLibName = Internal.mkGHCiProfLibName uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (cmmSources (libBuildInfo lib)) - && null (asmSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo - { HcPkg.hcPkgProgram = ghcPkgProg - , HcPkg.noPkgDbStack = v < [6,9] - , HcPkg.noVerboseFlag = v < [6,11] - , HcPkg.flagPackageConf = v < [7,5] - , HcPkg.supportsDirDbs = v >= [6,8] - , HcPkg.requiresDirDbs = v >= [7,10] - , HcPkg.nativeMultiInstance = v >= [7,10] - , HcPkg.recacheMultiInstance = v >= [6,12] - , HcPkg.suppressFilesCheck = v >= [6,6] - } - where - v = versionNumbers ver - ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb - ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) - pkgRoot' UserPackageDB = do - appDir <- getGhcAppDir - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - --- ----------------------------------------------------------------------------- --- Utils - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. +module Distribution.Simple.GHC + ( getGhcInfo + , configure + , configureCompiler + , compilerProgramDb + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , Internal.componentGhcOptions + , Internal.componentCcGhcOptions + , getGhcAppDir + , getLibDir + , compilerBuildWay + , getGlobalPackageDB + , pkgRoot + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Arrow ((***)) +import Control.Monad (forM_) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build.Inputs (PreBuildComponentInputs (..)) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import qualified Distribution.Simple.GHC.Build as GHC +import Distribution.Simple.GHC.Build.Modules (BuildWay (..)) +import Distribution.Simple.GHC.Build.Utils +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.Builtin (runghcProgram) +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Repl +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ParStrat +import Distribution.Types.TargetInfo +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.FilePath + ( isRelative + , takeDirectory + ) +import qualified System.Info +#ifndef mingw32_HOST_OS +import System.Posix (createSymbolicLink) +#endif /* mingw32_HOST_OS */ + +{- FOURMOLU_DISABLE -} +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getAppUserDataDirectory + , getDirectoryContents +#ifndef mingw32_HOST_OS + , renameFile +#endif + ) +{- FOURMOLU_ENABLE -} + +import Distribution.Simple.Setup (BuildingWhat (..)) +import Distribution.Simple.Setup.Build + +-- ----------------------------------------------------------------------------- +-- Configuring + +-- | Configure GHC, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. +configure + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHC. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do + (ghcProg, ghcVersion, progdb1) <- + requireProgramVersion + verbosity + ghcProgram + (orLaterVersion (mkVersion [7, 0, 1])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + + -- Cabal currently supports GHC less than `maxGhcVersion` + let maxGhcVersion = mkVersion [9, 16] + unless (ghcVersion < maxGhcVersion) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < " + ++ prettyShow maxGhcVersion + ++ "): " + ++ programPath ghcProg + ++ " is version " + ++ prettyShow ghcVersion + + let implInfo = ghcVersionImplInfo ghcVersion + languages <- Internal.getLanguages verbosity implInfo ghcProg + extensions0 <- Internal.getExtensions verbosity implInfo ghcProg + + ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg + + let ghcInfoMap = Map.fromList ghcInfo + filterJS = if ghcVersion < mkVersion [9, 8] then filterExt JavaScriptFFI else id + extensions = + -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214 + filterJS $ + -- see 'filterExtTH' comment below + filterExtTH $ + extensions0 + + -- starting with GHC 8.0, `TemplateHaskell` will be omitted from + -- `--supported-extensions` when it's not available. + -- for older GHCs we can use the "Have interpreter" property to + -- filter out `TemplateHaskell` + filterExtTH + | ghcVersion < mkVersion [8] + , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap = + filterExt TemplateHaskell + | otherwise = id + + filterExt ext = filter ((/= EnableExtension ext) . fst) + + compilerId :: CompilerId + compilerId = CompilerId GHC ghcVersion + + -- The @AbiTag@ is the @Project Unit Id@ but with redundant information from the compiler version removed. + -- For development versions of the compiler these look like: + -- @Project Unit Id@: "ghc-9.13-inplace" + -- @compilerId@: "ghc-9.13.20250413" + -- So, we need to be careful to only strip the /common/ prefix. + -- In this example, @AbiTag@ is "inplace". + compilerAbiTag :: AbiTag + compilerAbiTag = + maybe + NoAbiTag + AbiTag + ( dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId) + <$> Map.lookup "Project Unit Id" ghcInfoMap + ) + + let comp = + Compiler + { compilerId + , compilerAbiTag + , compilerCompat = [] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghc@ program, configure auxiliary programs such +-- as @ghc-pkg@ or @haddock@, as well as toolchain programs such as @ar@, @ld@, +-- based on: +-- +-- - the location of the @ghc@ executable, +-- - toolchain information in the GHC settings file. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcProg = fromJust $ lookupProgram ghcProgram progdb1 + ghcVersion = compilerVersion comp + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcPkgProgram + { programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion + (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1) + + when (ghcVersion /= ghcPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHC (programPath ghcProg) ghcVersion (programPath ghcPkgProg) ghcPkgVersion + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + haddockProgram' = + haddockProgram + { programFindLocation = guessHaddockFromGhcPath ghcProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcPath ghcProg + } + runghcProgram' = + runghcProgram + { programFindLocation = guessRunghcFromGhcPath ghcProg + } + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + addKnownProgram runghcProgram' progdb2 + + -- configure gcc, ld, ar etc... based on the paths stored + -- in the GHC settings file + progdb4 = + Internal.configureToolchain + (ghcVersionImplInfo ghcVersion) + ghcProg + (compilerProperties comp) + progdb3 + return progdb4 + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessToolFromGhcPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcPath tool ghcProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcVersioned dir suf = + dir + (toolname ++ "-ghc" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessNormal dir] + | otherwise = + [ guessGhcVersioned dir suf + , guessVersioned dir suf + , guessNormal dir + ] + -- order matters here, see https://github.com/haskell/cabal/issues/7390 + guesses = + ( if real_path == given_path + then [] + else mkGuesses real_dir real_suf + ) + ++ mkGuesses given_dir given_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +guessGhcPkgFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +guessHsc2hsFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding haddock, we try looking for both a versioned and unversioned +-- haddock in the same dir, that is: +-- +-- > /usr/local/bin/haddock-ghc-6.6.1(.exe) +-- > /usr/local/bin/haddock-6.6.1(.exe) +-- > /usr/local/bin/haddock(.exe) +guessHaddockFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram + +guessHpcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram + +guessRunghcFromGhcPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg + where + version = fromMaybe (error "GHC.getGhcInfo: no ghc version") $ programVersion ghcProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity mbWorkDir packagedb progdb = do + pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity comp packagedbs + pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! hackRtsPackage index + where + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc test suite does some crazy stuff. + +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a +-- @PackageIndex@. Helper function used by 'getPackageDBContents' and +-- 'getInstalledPackages'. +toPackageIndex + :: Verbosity + -> [(PackageDBX a, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! mconcat indices + where + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- | Return the 'FilePath' to the GHC application data directory. +-- +-- @since 3.4.0.0 +getGhcAppDir :: IO FilePath +getGhcAppDir = getAppUserDataDirectory "ghc" + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB + :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getGhcAppDir + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcVersion + packageConfFileName = "package.conf.d" + ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH" + +checkPackageDbStack :: Eq fp => Verbosity -> Compiler -> PackageDBStackX fp -> IO () +checkPackageDbStack verbosity comp = + if flagPackageConf implInfo + then checkPackageDbStackPre76 verbosity + else checkPackageDbStackPost76 verbosity + where + implInfo = ghcVersionImplInfo (compilerVersion comp) + +checkPackageDbStackPost76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStackPost76 _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPost76 verbosity rest + | GlobalPackageDB `elem` rest = + dieWithException verbosity CheckPackageDbStackPost76 +checkPackageDbStackPost76 _ _ = return () + +checkPackageDbStackPre76 :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStackPre76 _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStackPre76 verbosity rest + | GlobalPackageDB `notElem` rest = + dieWithException verbosity CheckPackageDbStackPre76 +checkPackageDbStackPre76 verbosity _ = + dieWithException verbosity GlobalPackageDbSpecifiedFirst + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg{InstalledPackageInfo.includeDirs = ids'} + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackages' + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> [PackageDBX (SymbolicPath from (Dir PkgDB))] + -> ProgramDb + -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])] +getInstalledPackages' verbosity mbWorkDir packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +getInstalledPackagesMonitorFiles + :: forall from + . Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> Platform + -> ProgramDb + -> [PackageDBS from] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity mbWorkDir platform progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDBS from -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path0 = do + let path = + if isRelative path0 + then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0) + else path0 + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: BuildFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildNormal flags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CLib lib) + } + +replLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib flags numJobs pkg lbi lib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl flags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CLib lib) + } + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity comp packageDBs + (ghcProg, _) <- requireProgram verbosity ghcProgram progdb + -- This doesn't pass source file arguments to GHC, so we don't have to worry + -- about using a response file here. + runGHC verbosity ghcProg comp platform Nothing replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v numJobs pkg lbi flib clbi = + GHC.build numJobs pkg $ + PreBuildComponentInputs + { buildingWhat = + BuildNormal $ + mempty + { buildCommonFlags = + mempty{setupVerbosity = toFlag v} + } + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CFLib flib) + } + +replFLib + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags njobs pkg lbi flib clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl replFlags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CFLib flib) + } + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = + BuildNormal $ + mempty + { buildCommonFlags = + mempty{setupVerbosity = toFlag v} + } + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CExe exe) + } + +replExe + :: ReplFlags + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags njobs pkg lbi exe clbi = + GHC.build njobs pkg $ + PreBuildComponentInputs + { buildingWhat = BuildRepl replFlags + , localBuildInfo = lbi + , targetInfo = TargetInfo clbi (CExe exe) + } + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +libAbiHash + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO String +libAbiHash verbosity _pkg_descr lbi lib clbi = do + let + libBi = libBuildInfo lib + comp = compiler lbi + platform = hostPlatform lbi + mbWorkDir = mbWorkDirLBI lbi + vanillaArgs = + (Internal.componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) + `mappend` mempty + { ghcOptMode = toFlag GhcModeAbiHash + , ghcOptInputModules = toNubListR $ exposedModules lib + } + sharedArgs = + vanillaArgs + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + } + profArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcProfOptions GHC libBi + } + profDynArgs = + vanillaArgs + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "p_dyn_hi" + , ghcOptObjSuffix = toFlag "p_dyn_o" + , ghcOptExtra = hcOptions GHC libBi ++ hcProfSharedOptions GHC libBi + } + ghcArgs = + let (libWays, _, _) = buildWays lbi + in case libWays (componentIsIndefinite clbi) of + (ProfDynWay : _) -> profDynArgs + (ProfWay : _) -> profArgs + (StaticWay : _) -> vanillaArgs + (DynWay : _) -> sharedArgs + _ -> error "libAbiHash: Can't find an enabled library way" + + (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi) + + hash <- + getProgramInvocationOutput + verbosity + =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir ghcArgs + + return (takeWhile (not . isSpace) hash) + +-- ----------------------------------------------------------------------------- +-- Installing + +-- | Install executables for GHC. +installExe + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ Where to copy the files to + -> FilePath + -- ^ Build location + -> (FilePath, FilePath) + -- ^ Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe + verbosity + lbi + binDir + buildPref + (progprefix, progsuffix) + _pkg + exe = do + createDirectoryIfMissingVerbose verbosity True binDir + let exeName' = unUnqualComponentName $ exeName exe + exeFileName = exeTargetName (hostPlatform lbi) (exeName exe) + fixedExeBaseName = progprefix ++ exeName' ++ progsuffix + installBinary dest = do + installExecutableFile + verbosity + (buildPref exeName' exeFileName) + (dest <.> exeExtension (hostPlatform lbi)) + when (stripExes lbi) $ + Strip.stripExe + verbosity + (hostPlatform lbi) + (withPrograms lbi) + (dest <.> exeExtension (hostPlatform lbi)) + installBinary (binDir fixedExeBaseName) + +-- | Install foreign library for GHC. +installFLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ Build location + -> PackageDescription + -> ForeignLib + -> IO () +installFLib verbosity lbi targetDir builtDir _pkg flib = + install + (foreignLibIsShared flib) + builtDir + targetDir + (flibTargetName lbi flib) + where + install isShared srcDir dstDir name = do + let src = srcDir name + dst = dstDir name + createDirectoryIfMissingVerbose verbosity True targetDir + -- TODO: Should we strip? (stripLibs lbi) + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + -- Now install appropriate symlinks if library is versioned + let (Platform _ os) = hostPlatform lbi + when (not (null (foreignLibVersion flib os))) $ do + when (os /= Linux) $ + dieWithException verbosity $ + CantInstallForeignLib +#ifndef mingw32_HOST_OS + -- 'createSymbolicLink file1 file2' creates a symbolic link + -- named 'file2' which points to the file 'file1'. + -- Note that we do want a symlink to 'name' rather than + -- 'dst', because the symlink will be relative to the + -- directory it's created in. + -- Finally, we first create the symlinks in a temporary + -- directory and then rename to simulate 'ln --force'. + withTempDirectory verbosity dstDir nm $ \tmpDir -> do + let link1 = flibBuildName lbi flib + link2 = "lib" ++ nm <.> "so" + createSymbolicLink name (tmpDir link1) + renameFile (tmpDir link1) (dstDir link1) + createSymbolicLink name (tmpDir link2) + renameFile (tmpDir link2) (dstDir link2) + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib +#endif /* mingw32_HOST_OS */ + +-- | Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -- ^ install location + -> FilePath + -- ^ install location for dynamic libraries + -> FilePath + -- ^ Build location + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do + let + (wantedLibWays, _, _) = buildWays lbi + isIndef = componentIsIndefinite clbi + libWays = wantedLibWays isIndef + + info verbosity ("Wanted install ways: " ++ show libWays) + + -- copy .hi files over: + forM_ (wantedLibWays isIndef) $ \w -> case w of + StaticWay -> copyModuleFiles (Suffix "hi") + DynWay -> copyModuleFiles (Suffix "dyn_hi") + ProfWay -> copyModuleFiles (Suffix "p_hi") + ProfDynWay -> copyModuleFiles (Suffix "p_dyn_hi") + + -- copy extra compilation artifacts that ghc plugins may produce + copyDirectoryIfExists extraCompilationArtifacts + + -- copy the built library files over: + when (has_code && hasLib) $ do + forM_ libWays $ \w -> case w of + StaticWay -> do + sequence_ + [ installOrdinary + builtDir + targetDir + (mkGenericStaticLibName (l ++ f)) + | l <- + getHSLibraryName + (componentUnitId clbi) + : (extraBundledLibs (libBuildInfo lib)) + , f <- "" : extraLibFlavours (libBuildInfo lib) + ] + whenGHCi $ installOrdinary builtDir targetDir ghciLibName + ProfWay -> do + installOrdinary builtDir targetDir profileLibName + whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName + ProfDynWay -> do + installShared + builtDir + dynlibTargetDir + (mkProfSharedLibName platform compiler_id uid) + DynWay -> do + if + -- The behavior for "extra-bundled-libraries" changed in version 2.5.0. + -- See ghc issue #15837 and Cabal PR #5855. + | specVersion pkg < CabalSpecV3_0 -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + (mkGenericSharedLibName platform compiler_id (l ++ f)) + | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + | otherwise -> do + sequence_ + [ installShared + builtDir + dynlibTargetDir + ( mkGenericSharedLibName + platform + compiler_id + (getHSLibraryName uid ++ f) + ) + | f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + sequence_ + [ do + files <- getDirectoryContents (i builtDir) + let l' = + mkGenericSharedBundledLibName + platform + compiler_id + (l ++ f) + forM_ files $ \file -> + when (l' `isPrefixOf` file) $ do + isFile <- doesFileExist (i $ builtDir makeRelativePathEx file) + when isFile $ do + installShared + builtDir + dynlibTargetDir + file + | l <- extraBundledLibs (libBuildInfo lib) + , f <- "" : extraDynLibFlavours (libBuildInfo lib) + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + + builtDir = componentBuildDir lbi clbi + mbWorkDir = mbWorkDirLBI lbi + + install isShared srcDir dstDir name = do + let src = i $ srcDir makeRelativePathEx name + dst = dstDir name + + createDirectoryIfMissingVerbose verbosity True dstDir + + if isShared + then installExecutableFile verbosity src dst + else installOrdinaryFile verbosity src dst + + when (stripLibs lbi) $ + Strip.stripLib + verbosity + platform + (withPrograms lbi) + dst + + installOrdinary = install False + installShared = install True + + copyModuleFiles ext = do + files <- findModuleFilesCwd verbosity mbWorkDir [builtDir] [ext] (allLibModules lib clbi) + let files' = map (i *** getSymbolicPath) files + installOrdinaryFiles verbosity targetDir files' + + copyDirectoryIfExists :: RelativePath Build (Dir Artifacts) -> IO () + copyDirectoryIfExists dirName = do + let src = i $ builtDir dirName + dst = targetDir getSymbolicPath dirName + dirExists <- doesDirectoryExist src + when dirExists $ copyDirectoryRecursive verbosity src dst + + compiler_id = compilerId (compiler lbi) + platform = hostPlatform lbi + uid = componentUnitId clbi + profileLibName = mkProfLibName uid + ghciLibName = Internal.mkGHCiLibName uid + ghciProfLibName = Internal.mkGHCiProfLibName uid + + hasLib = + not $ + null (allLibModules lib clbi) + && null (cSources (libBuildInfo lib)) + && null (cxxSources (libBuildInfo lib)) + && null (cmmSources (libBuildInfo lib)) + && null (asmSources (libBuildInfo lib)) + && (null (jsSources (libBuildInfo lib)) || not hasJsSupport) + hasJsSupport = case hostPlatform lbi of + Platform JavaScript _ -> True + _ -> False + has_code = not (componentIsIndefinite clbi) + whenGHCi = when (hasLib && withGHCiLib lbi && has_code) + +-- ----------------------------------------------------------------------------- +-- Registering + +hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo +hcPkgInfo progdb = + HcPkg.HcPkgInfo + { HcPkg.hcPkgProgram = ghcPkgProg + , HcPkg.noPkgDbStack = v < [6, 9] + , HcPkg.noVerboseFlag = v < [6, 11] + , HcPkg.flagPackageConf = v < [7, 5] + , HcPkg.supportsDirDbs = v >= [6, 8] + , HcPkg.requiresDirDbs = v >= [7, 10] + , HcPkg.nativeMultiInstance = v >= [7, 10] + , HcPkg.recacheMultiInstance = v >= [6, 12] + , HcPkg.suppressFilesCheck = v >= [6, 6] + } + where + v = versionNumbers ver + ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb + ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg + +registerPackage + :: Verbosity + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions = + HcPkg.register + (hcPkgInfo progdb) + verbosity + mbWorkDir + packageDbs + installedPkgInfo + registerOptions + +pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO (SymbolicPath CWD (Dir Pkg)) +pkgRoot verbosity lbi = fmap makeSymbolicPath . pkgRoot' + where + pkgRoot' GlobalPackageDB = + let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi) + in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg) + pkgRoot' UserPackageDB = do + appDir <- getGhcAppDir + let ver = compilerVersion (compiler lbi) + subdir = + System.Info.arch + ++ '-' + : System.Info.os + ++ '-' + : prettyShow ver + rootDir = appDir subdir + -- We must create the root directory for the user package database if it + -- does not yet exist. Otherwise '${pkgroot}' will resolve to a + -- directory at the time of 'ghc-pkg register', and registration will + -- fail. + createDirectoryIfMissing True rootDir + return rootDir + pkgRoot' (SpecificPackageDB fp) = + return $ + takeDirectory $ + interpretSymbolicPathLBI lbi fp diff --git a/src/Distribution/Simple/GHC/Build.hs b/src/Distribution/Simple/GHC/Build.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build.hs @@ -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/-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 == /cabal-benchmarks + buildTargetDir == /cabal-benchmarks/cabal-benchmarks-tmp + +Or, for a library `Cabal`: + targetDir == /. + 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/-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 diff --git a/src/Distribution/Simple/GHC/Build/ExtraSources.hs b/src/Distribution/Simple/GHC/Build/ExtraSources.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/ExtraSources.hs @@ -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) diff --git a/src/Distribution/Simple/GHC/Build/Link.hs b/src/Distribution/Simple/GHC/Build/Link.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Link.hs @@ -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@. 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 diff --git a/src/Distribution/Simple/GHC/Build/Modules.hs b/src/Distribution/Simple/GHC/Build/Modules.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Modules.hs @@ -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) diff --git a/src/Distribution/Simple/GHC/Build/Utils.hs b/src/Distribution/Simple/GHC/Build/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/GHC/Build/Utils.hs @@ -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) diff --git a/src/Distribution/Simple/GHC/EnvironmentParser.hs b/src/Distribution/Simple/GHC/EnvironmentParser.hs --- a/src/Distribution/Simple/GHC/EnvironmentParser.hs +++ b/src/Distribution/Simple/GHC/EnvironmentParser.hs @@ -1,49 +1,53 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Simple.GHC.EnvironmentParser - ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where -import Prelude () +module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where + import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler - ( PackageDB(..) ) import Distribution.Simple.GHC.Internal - ( GhcEnvironmentFileEntry(..) ) + ( GhcEnvironmentFileEntry (..) + ) import Distribution.Types.UnitId - ( mkUnitId ) + ( mkUnitId + ) import qualified Text.Parsec as P import Text.Parsec.String - ( Parser, parseFromFile ) + ( Parser + , parseFromFile + ) -parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry -parseEnvironmentFileLine = GhcEnvFileComment <$> comment - <|> GhcEnvFilePackageId <$> unitId - <|> GhcEnvFilePackageDb <$> packageDb - <|> pure GhcEnvFileClearPackageDbStack <* clearDb - where - comment = P.string "--" *> P.many (P.noneOf "\r\n") - unitId = P.try $ P.string "package-id" *> P.spaces *> - (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) - packageDb = (P.string "global-package-db" *> pure GlobalPackageDB) - <|> (P.string "user-package-db" *> pure UserPackageDB) - <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) - clearDb = P.string "clear-package-db" +parseEnvironmentFileLine :: Parser (GhcEnvironmentFileEntry FilePath) +parseEnvironmentFileLine = + GhcEnvFileComment <$> comment + <|> GhcEnvFilePackageId <$> unitId + <|> GhcEnvFilePackageDb <$> packageDb + <|> pure GhcEnvFileClearPackageDbStack <* clearDb + where + comment = P.string "--" *> P.many (P.noneOf "\r\n") + unitId = + P.try $ + P.string "package-id" + *> P.spaces + *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+")) + packageDb = + (P.string "global-package-db" *> pure GlobalPackageDB) + <|> (P.string "user-package-db" *> pure UserPackageDB) + <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine)) + clearDb = P.string "clear-package-db" newtype ParseErrorExc = ParseErrorExc P.ParseError - deriving (Show, Typeable) + deriving (Show) instance Exception ParseErrorExc -parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry] +parseGhcEnvironmentFile :: Parser [GhcEnvironmentFileEntry FilePath] parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P.eof -readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry] +readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry FilePath] readGhcEnvironmentFile path = - either (throwIO . ParseErrorExc) return =<< - parseFromFile parseGhcEnvironmentFile path + either (throwIO . ParseErrorExc) return + =<< parseFromFile parseGhcEnvironmentFile path diff --git a/src/Distribution/Simple/GHC/ImplInfo.hs b/src/Distribution/Simple/GHC/ImplInfo.hs --- a/src/Distribution/Simple/GHC/ImplInfo.hs +++ b/src/Distribution/Simple/GHC/ImplInfo.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.GHC.ImplInfo -- @@ -8,89 +9,127 @@ -- This module contains the data structure describing invocation -- details for a GHC or GHC-derived compiler, such as supported flags -- and workarounds for bugs. - -module Distribution.Simple.GHC.ImplInfo ( - GhcImplInfo(..), getImplInfo, - ghcVersionImplInfo, ghcjsVersionImplInfo - ) where +module Distribution.Simple.GHC.ImplInfo + ( GhcImplInfo (..) + , getImplInfo + , ghcVersionImplInfo + , ghcjsVersionImplInfo + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler import Distribution.Version -{- | - Information about features and quirks of a GHC-based implementation. - - Compiler flavors based on GHC behave similarly enough that some of - the support code for them is shared. Every implementation has its - own peculiarities, that may or may not be a direct result of the - underlying GHC version. This record keeps track of these differences. - - All shared code (i.e. everything not in the Distribution.Simple.FLAVOR - module) should use implementation info rather than version numbers - to test for supported features. --} - +-- | +-- Information about features and quirks of a GHC-based implementation. +-- +-- Compiler flavors based on GHC behave similarly enough that some of +-- the support code for them is shared. Every implementation has its +-- own peculiarities, that may or may not be a direct result of the +-- underlying GHC version. This record keeps track of these differences. +-- +-- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR +-- module) should use implementation info rather than version numbers +-- to test for supported features. data GhcImplInfo = GhcImplInfo - { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags - , supportsGHC2021 :: Bool -- ^ -XGHC2021 flag - , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt - , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on - , flagGhciScript :: Bool -- ^ -ghci-script flag supported - , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags - , flagPackageConf :: Bool -- ^ use package-conf instead of package-db - , flagDebugInfo :: Bool -- ^ -g flag supported - , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels - , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files - , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported + { supportsHaskell2010 :: Bool + -- ^ -XHaskell2010 and -XHaskell98 flags + , supportsGHC2021 :: Bool + -- ^ -XGHC2021 flag + , supportsGHC2024 :: Bool + -- ^ -XGHC2024 flag + , reportsNoExt :: Bool + -- ^ --supported-languages gives Ext and NoExt + , alwaysNondecIndent :: Bool + -- ^ NondecreasingIndentation is always on + , flagGhciScript :: Bool + -- ^ -ghci-script flag supported + , flagProfAuto :: Bool + -- ^ new style -fprof-auto* flags + , flagProfLate :: Bool + -- ^ fprof-late flag + , flagPackageConf :: Bool + -- ^ use package-conf instead of package-db + , flagDebugInfo :: Bool + -- ^ -g flag supported + , flagHie :: Bool + -- ^ -hiedir flag supported + , supportsDebugLevels :: Bool + -- ^ supports numeric @-g@ levels + , supportsPkgEnvFiles :: Bool + -- ^ picks up @.ghc.environment@ files + , flagWarnMissingHomeModules :: Bool + -- ^ -Wmissing-home-modules is supported + , unitIdForExes :: Bool + -- ^ Pass -this-unit-id flag when building executables } getImplInfo :: Compiler -> GhcImplInfo getImplInfo comp = case compilerFlavor comp of - GHC -> ghcVersionImplInfo (compilerVersion comp) + GHC -> ghcVersionImplInfo (compilerVersion comp) GHCJS -> case compilerCompatVersion GHC comp of - Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer - _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++ - "could not find GHC version for GHCJS compiler") - x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++ - "for GHC-like compilers (GHC, GHCJS)" ++ - ", but found " ++ show x) + Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer + _ -> + error + ( "Distribution.Simple.GHC.Props.getImplProps: " + ++ "could not find GHC version for GHCJS compiler" + ) + x -> + error + ( "Distribution.Simple.GHC.Props.getImplProps only works" + ++ "for GHC-like compilers (GHC, GHCJS)" + ++ ", but found " + ++ show x + ) ghcVersionImplInfo :: Version -> GhcImplInfo -ghcVersionImplInfo ver = GhcImplInfo - { supportsHaskell2010 = v >= [7] - , supportsGHC2021 = v >= [9,1] - , reportsNoExt = v >= [7] - , alwaysNondecIndent = v < [7,1] - , flagGhciScript = v >= [7,2] - , flagProfAuto = v >= [7,4] - , flagPackageConf = v < [7,5] - , flagDebugInfo = v >= [7,10] - , supportsDebugLevels = v >= [8,0] - , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2 - , flagWarnMissingHomeModules = v >= [8,2] - } +ghcVersionImplInfo ver = + GhcImplInfo + { supportsHaskell2010 = v >= [7] + , supportsGHC2021 = v >= [9, 1] + , supportsGHC2024 = v >= [9, 9] + , reportsNoExt = v >= [7] + , alwaysNondecIndent = v < [7, 1] + , flagGhciScript = v >= [7, 2] + , flagProfAuto = v >= [7, 4] + , flagProfLate = v >= [9, 4] + , flagPackageConf = v < [7, 5] + , flagDebugInfo = v >= [7, 10] + , flagHie = v >= [8, 8] + , supportsDebugLevels = v >= [8, 0] + , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2 + , flagWarnMissingHomeModules = v >= [8, 2] + , unitIdForExes = v >= [9, 2] + } where v = versionNumbers ver -ghcjsVersionImplInfo :: Version -- ^ The GHCJS version - -> Version -- ^ The GHC version - -> GhcImplInfo -ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo - { supportsHaskell2010 = True - , supportsGHC2021 = True - , reportsNoExt = True - , alwaysNondecIndent = False - , flagGhciScript = True - , flagProfAuto = True - , flagPackageConf = False - , flagDebugInfo = False - , supportsDebugLevels = ghcv >= [8,0] - , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs - , flagWarnMissingHomeModules = ghcv >= [8,2] - } +ghcjsVersionImplInfo + :: Version + -- ^ The GHCJS version + -> Version + -- ^ The GHC version + -> GhcImplInfo +ghcjsVersionImplInfo _ghcjsver ghcver = + GhcImplInfo + { supportsHaskell2010 = True + , supportsGHC2021 = True + , supportsGHC2024 = ghcv >= [9, 9] + , reportsNoExt = True + , alwaysNondecIndent = False + , flagGhciScript = True + , flagProfAuto = True + , flagProfLate = True + , flagPackageConf = False + , flagDebugInfo = False + , flagHie = ghcv >= [8, 8] + , supportsDebugLevels = ghcv >= [8, 0] + , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs + , flagWarnMissingHomeModules = ghcv >= [8, 2] + , unitIdForExes = ghcv >= [9, 2] + } where ghcv = versionNumbers ghcver diff --git a/src/Distribution/Simple/GHC/Internal.hs b/src/Distribution/Simple/GHC/Internal.hs --- a/src/Distribution/Simple/GHC/Internal.hs +++ b/src/Distribution/Simple/GHC/Internal.hs @@ -1,686 +1,864 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.GHC.Internal --- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains functions shared by GHC (Distribution.Simple.GHC) --- and GHC-derived compilers. - -module Distribution.Simple.GHC.Internal ( - configureToolchain, - getLanguages, - getExtensions, - targetPlatform, - getGhcInfo, - componentCcGhcOptions, - componentCmmGhcOptions, - componentCxxGhcOptions, - componentAsmGhcOptions, - componentGhcOptions, - mkGHCiLibName, - mkGHCiProfLibName, - filterGhciFlags, - ghcLookupProperty, - getHaskellObjects, - mkGhcOptPackages, - substTopDir, - checkPackageDbEnvVar, - profDetailLevelFlag, - -- * GHC platform and version strings - ghcArchString, - ghcOsString, - ghcPlatformAndVersionString, - -- * Constructing GHC environment files - GhcEnvironmentFileEntry(..), - writeGhcEnvironmentFile, - simpleGhcEnvironmentFile, - ghcEnvironmentFileName, - renderGhcEnvironmentFile, - renderGhcEnvironmentFileEntry, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Simple.GHC.ImplInfo -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Backpack -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.PackageDescription -import Distribution.Lex -import Distribution.Simple.Compiler -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.UnitId -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.System -import Distribution.Pretty ( prettyShow ) -import Distribution.Parsec ( simpleParsec ) -import Distribution.Utils.NubList ( toNubListR ) -import Distribution.Verbosity -import Distribution.Compat.Stack -import Distribution.Version (Version) -import Distribution.Utils.Path -import Language.Haskell.Extension - -import qualified Data.Map as Map -import qualified Data.ByteString.Lazy.Char8 as BS -import System.Directory ( getDirectoryContents, getTemporaryDirectory ) -import System.Environment ( getEnv ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, takeFileName) -import System.IO ( hClose, hPutStrLn ) - -targetPlatform :: [(String, String)] -> Maybe Platform -targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: GhcImplInfo - -> ConfiguredProgram - -> Map String String - -> ProgramDb - -> ProgramDb -configureToolchain _implInfo ghcProg ghcInfo = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgramName extraGccPath, - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgramName extraLdPath, - programPostConf = configureLd - } - . addKnownProgram arProgram { - programFindLocation = findProg arProgramName extraArPath - } - . addKnownProgram stripProgram { - programFindLocation = findProg stripProgramName extraStripPath - } - where - compilerDir = takeDirectory (programPath ghcProg) - base_dir = takeDirectory compilerDir - mingwBinDir = base_dir "mingw" "bin" - isWindows = case buildOS of Windows -> True; _ -> False - binPrefix = "" - - maybeName :: Program -> Maybe FilePath -> String - maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) - - gccProgramName = maybeName gccProgram mbGccLocation - ldProgramName = maybeName ldProgram mbLdLocation - arProgramName = maybeName arProgram mbArLocation - stripProgramName = maybeName stripProgram mbStripLocation - - mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] - mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath] - | otherwise = mbDir - where - mbDir = maybeToList . fmap takeDirectory $ mbPath - - extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir - extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir - extraArPath = mkExtraPath mbArLocation windowsExtraArDir - extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir - - -- on Windows finding and configuring ghc's gcc & binutils is a bit special - (windowsExtraGccDir, windowsExtraLdDir, - windowsExtraArDir, windowsExtraStripDir) = - let b = mingwBinDir binPrefix - in (b, b, b, b) - - findProg :: String -> [FilePath] - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) - findProg progName extraPath v searchpath = - findProgramOnSearchPath v searchpath' progName - where - searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath - - -- Read tool locations from the 'ghc --info' output. Useful when - -- cross-compiling. - mbGccLocation = Map.lookup "C compiler command" ghcInfo - mbLdLocation = Map.lookup "ld command" ghcInfo - mbArLocation = Map.lookup "ar command" ghcInfo - mbStripLocation = Map.lookup "strip command" ghcInfo - - ccFlags = getFlags "C compiler flags" - -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" - -- and "Ld Linker flags" to "ld flags" (GHC #4862). - gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" - ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" - - -- It appears that GHC 7.6 and earlier encode the tokenized flags as a - -- [String] in these settings whereas later versions just encode the flags as - -- String. - -- - -- We first try to parse as a [String] and if this fails then tokenize the - -- flags ourself. - getFlags :: String -> [String] - getFlags key = - case Map.lookup key ghcInfo of - Nothing -> [] - Just flags - | (flags', ""):_ <- reads flags -> flags' - | otherwise -> tokenizeQuotedWords flags - - configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureGcc _v gccProg = do - return gccProg { - programDefaultArgs = programDefaultArgs gccProg - ++ ccFlags ++ gccLinkerFlags - } - - configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd v ldProg = do - ldProg' <- configureLd' v ldProg - return ldProg' { - programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags - } - - -- we need to find out if ld supports the -x flag - configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram - configureLd' verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() { return 0; }" - hClose testchnd; hClose testohnd - runProgram verbosity ghcProg - [ "-hide-all-packages" - , "-c", testcfile - , "-o", testofile - ] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - do - hClose testohnd' - _ <- getProgramOutput verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - if ldx - then return ldProg { programDefaultArgs = ["-x"] } - else return ldProg - -getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Language, String)] -getLanguages _ implInfo _ - -- TODO: should be using --supported-languages rather than hard coding - | supportsGHC2021 implInfo = return - [ (GHC2021, "-XGHC2021") - , (Haskell2010, "-XHaskell2010") - , (Haskell98, "-XHaskell98") - ] - | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98") - ,(Haskell2010, "-XHaskell2010")] - | otherwise = return [(Haskell98, "")] - -getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(String, String)] -getGhcInfo verbosity _implInfo ghcProg = do - xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--info"] - case reads xs of - [(i, ss)] - | all isSpace ss -> - return i - _ -> - die' verbosity "Can't parse --info output of GHC" - -getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram - -> IO [(Extension, Maybe String)] -getExtensions verbosity implInfo ghcProg = do - str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg) - ["--supported-languages"] - let extStrs = if reportsNoExt implInfo - then lines str - else -- Older GHCs only gave us either Foo or NoFoo, - -- so we have to work out the other one ourselves - [ extStr'' - | extStr <- lines str - , let extStr' = case extStr of - 'N' : 'o' : xs -> xs - _ -> "No" ++ extStr - , extStr'' <- [extStr, extStr'] - ] - let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext) - | Just ext <- map simpleParsec extStrs ] - extensions1 = if alwaysNondecIndent implInfo - then -- ghc-7.2 split NondecreasingIndentation off - -- into a proper extension. Before that it - -- was always on. - -- Since it was not a proper extension, it could - -- not be turned off, hence we omit a - -- DisableExtension entry here. - (EnableExtension NondecreasingIndentation, Nothing) : - extensions0 - else extensions0 - return extensions1 - -componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCcOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - ccOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptCxxOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - cxxOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptAsmOptions = (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-O2"]) ++ - (case withDebugInfo lbi of - NoDebugInfo -> [] - MinimalDebugInfo -> ["-g1"] - NormalDebugInfo -> ["-g"] - MaximalDebugInfo -> ["-g3"]) ++ - asmOptions bi, - ghcOptObjDir = toFlag odir - } - - -componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity implInfo lbi bi clbi odir = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptCabal = toFlag True, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentComponentId = cid - , componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag cid - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptNoCode = toFlag $ componentIsIndefinite clbi, - ghcOptHideAllPackages = toFlag True, - ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptSplitSections = toFlag (splitSections lbi), - ghcOptSplitObjs = toFlag (splitObjs lbi), - ghcOptSourcePathClear = toFlag True, - ghcOptSourcePath = toNubListR $ [odir] ++ (map getSymbolicPath (hsSourceDirs bi)) - ++ [autogenComponentModulesDir lbi clbi] - ++ [autogenPackageModulesDir lbi], - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptFfiIncludes = toNubListR $ includes bi, - ghcOptObjDir = toFlag odir, - ghcOptHiDir = toFlag odir, - ghcOptStubDir = toFlag odir, - ghcOptOutputDir = toFlag odir, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = hcOptions GHC bi, - ghcOptExtraPath = toNubListR $ exe_paths, - ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)), - -- Unsupported extensions have already been checked by configure - ghcOptExtensions = toNubListR $ usedExtensions bi, - ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) - } - where - exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt) - | uid <- componentExeDeps clbi - -- TODO: Ugh, localPkgDescr - , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ] - -toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation -toGhcOptimisation NoOptimisation = mempty --TODO perhaps override? -toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation -toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation - - -componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename = - mempty { - -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! - ghcOptVerbosity = toFlag (min verbosity normal), - ghcOptMode = toFlag GhcModeCompile, - ghcOptInputFiles = toNubListR [filename], - - ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] - -- includes relative to the package - ++ includeDirs bi - -- potential includes generated by `configure' - -- in the build directory - ++ [buildDir lbi dir | dir <- includeDirs bi], - ghcOptCppOptions = cppOptions bi, - ghcOptCppIncludes = toNubListR $ - [autogenComponentModulesDir lbi clbi cppHeaderName], - ghcOptHideAllPackages= toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptPackages = toNubListR $ mkGhcOptPackages clbi, - ghcOptOptimisation = toGhcOptimisation (withOptimization lbi), - ghcOptDebugInfo = toFlag (withDebugInfo lbi), - ghcOptExtra = cmmOptions bi, - ghcOptObjDir = toFlag odir - } - - --- | Strip out flags that are not supported in ghci -filterGhciFlags :: [String] -> [String] -filterGhciFlags = filter supported - where - supported ('-':'O':_) = False - supported "-debug" = False - supported "-threaded" = False - supported "-ticky" = False - supported "-eventlog" = False - supported "-prof" = False - supported "-unreg" = False - supported _ = True - -mkGHCiLibName :: UnitId -> String -mkGHCiLibName lib = getHSLibraryName lib <.> "o" - -mkGHCiProfLibName :: UnitId -> String -mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" - -ghcLookupProperty :: String -> Compiler -> Bool -ghcLookupProperty prop comp = - case Map.lookup prop (compilerProperties comp) of - Just "YES" -> True - _ -> False - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" - dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) - | x <- allLibModules lib clbi ] - objss <- traverse getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- allLibModules lib clbi ] - -mkGhcOptPackages :: ComponentLocalBuildInfo - -> [(OpenUnitId, ModuleRenaming)] -mkGhcOptPackages = componentIncludes - -substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo -substTopDir topDir ipo - = ipo { - IPI.importDirs = map f (IPI.importDirs ipo), - IPI.libraryDirs = map f (IPI.libraryDirs ipo), - IPI.includeDirs = map f (IPI.includeDirs ipo), - IPI.frameworkDirs = map f (IPI.frameworkDirs ipo), - IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo), - IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) - } - where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest - f x = x - --- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let --- users know that this is the case. See ticket #335. Simply ignoring it is --- not a good idea, since then ghc and cabal are looking at different sets --- of package DBs and chaos is likely to ensue. --- --- An exception to this is when running cabal from within a `cabal exec` --- environment. In this case, `cabal exec` will set the --- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set --- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow --- GHC{,JS}_PACKAGE_PATH. -checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () -checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do - mPP <- lookupEnv packagePathEnvVar - when (isJust mPP) $ do - mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" - unless (mPP == mcsPP) abort - where - lookupEnv :: String -> IO (Maybe String) - lookupEnv name = (Just `fmap` getEnv name) - `catchIO` const (return Nothing) - abort = - die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable " - ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the " - ++ "flag --package-db to specify a package database (it can be " - ++ "used multiple times)." - - _ = callStack -- TODO: output stack when erroring - -profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto -profDetailLevelFlag forLib mpl = - case mpl of - ProfDetailNone -> mempty - ProfDetailDefault | forLib -> toFlag GhcProfAutoExported - | otherwise -> toFlag GhcProfAutoToplevel - ProfDetailExportedFunctions -> toFlag GhcProfAutoExported - ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel - ProfDetailAllFunctions -> toFlag GhcProfAutoAll - ProfDetailOther _ -> mempty - - --- ----------------------------------------------------------------------------- --- GHC platform and version strings - --- | GHC's rendering of its host or target 'Arch' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcArchString :: Arch -> String -ghcArchString PPC = "powerpc" -ghcArchString PPC64 = "powerpc64" -ghcArchString other = prettyShow other - --- | GHC's rendering of its host or target 'OS' as used in its platform --- strings and certain file locations (such as user package db location). --- -ghcOsString :: OS -> String -ghcOsString Windows = "mingw32" -ghcOsString OSX = "darwin" -ghcOsString Solaris = "solaris2" -ghcOsString other = prettyShow other - --- | GHC's rendering of its platform and compiler version string as used in --- certain file locations (such as user package db location). --- For example @x86_64-linux-7.10.4@ --- -ghcPlatformAndVersionString :: Platform -> Version -> String -ghcPlatformAndVersionString (Platform arch os) version = - intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ] - - --- ----------------------------------------------------------------------------- --- Constructing GHC environment files - --- | The kinds of entries we can stick in a @.ghc.environment@ file. --- -data GhcEnvironmentFileEntry = - GhcEnvFileComment String -- ^ @-- a comment@ - | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@ - | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@, - -- @user-package-db@ or - -- @package-db blah/package.conf.d/@ - | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@ - deriving (Eq, Ord, Show) - --- | Make entries for a GHC environment file based on a 'PackageDBStack' and --- a bunch of package (unit) ids. --- --- If you need to do anything more complicated then either use this as a basis --- and add more entries, or just make all the entries directly. --- -simpleGhcEnvironmentFile :: PackageDBStack - -> [UnitId] - -> [GhcEnvironmentFileEntry] -simpleGhcEnvironmentFile packageDBs pkgids = - GhcEnvFileClearPackageDbStack - : map GhcEnvFilePackageDb packageDBs - ++ map GhcEnvFilePackageId pkgids - --- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. --- --- The 'Platform' and GHC 'Version' are needed as part of the file name. --- --- Returns the name of the file written. -writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it - -> Platform -- ^ the GHC target platform - -> Version -- ^ the GHC version - -> [GhcEnvironmentFileEntry] -- ^ the content - -> IO FilePath -writeGhcEnvironmentFile directory platform ghcversion entries = do - writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries - return envfile - where - envfile = directory ghcEnvironmentFileName platform ghcversion - --- | The @.ghc.environment-$arch-$os-$ver@ file name --- -ghcEnvironmentFileName :: Platform -> Version -> FilePath -ghcEnvironmentFileName platform ghcversion = - ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion - --- | Render a bunch of GHC environment file entries --- -renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String -renderGhcEnvironmentFile = - unlines . map renderGhcEnvironmentFileEntry - --- | Render an individual GHC environment file entry --- -renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String -renderGhcEnvironmentFileEntry entry = case entry of - GhcEnvFileComment comment -> format comment - where format = intercalate "\n" . map ("--" <++>) . lines - pref <++> "" = pref - pref <++> str = pref ++ " " ++ str - GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid - GhcEnvFilePackageDb pkgdb -> - case pkgdb of - GlobalPackageDB -> "global-package-db" - UserPackageDB -> "user-package-db" - SpecificPackageDB dbfile -> "package-db " ++ dbfile - GhcEnvFileClearPackageDbStack -> "clear-package-db" +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.GHC.Internal +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains functions shared by GHC (Distribution.Simple.GHC) +-- and GHC-derived compilers. +module Distribution.Simple.GHC.Internal + ( configureToolchain + , getLanguages + , getExtensions + , targetPlatform + , getGhcInfo + , componentCcGhcOptions + , componentCmmGhcOptions + , componentCxxGhcOptions + , componentAsmGhcOptions + , componentJsGhcOptions + , componentGhcOptions + , mkGHCiLibName + , mkGHCiProfLibName + , filterGhciFlags + , ghcLookupProperty + , getHaskellObjects + , mkGhcOptPackages + , substTopDir + , checkPackageDbEnvVar + , profDetailLevelFlag + + -- * GHC platform and version strings + , ghcArchString + , ghcOsString + , ghcPlatformAndVersionString + + -- * Constructing GHC environment files + , GhcEnvironmentFileEntry (..) + , writeGhcEnvironmentFile + , simpleGhcEnvironmentFile + , ghcEnvironmentFileName + , renderGhcEnvironmentFile + , renderGhcEnvironmentFileEntry + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Data.Bool (bool) +import qualified Data.ByteString.Lazy.Char8 as BS +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Backpack +import Distribution.Compat.Stack +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Lex +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag, pattern NoFlag) +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import Distribution.Simple.Setup.Common (extraCompilationArtifacts) +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.GivenComponent +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Utils.NubList (NubListR, toNubListR) +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version (Version) +import Language.Haskell.Extension +import System.Directory (getDirectoryContents) +import System.Environment (getEnv) +import System.FilePath + ( takeDirectory + , takeExtension + , takeFileName + ) +import System.IO (hClose, hPutStrLn) + +targetPlatform :: [(String, String)] -> Maybe Platform +targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo + +-- | Adjust the way we find and configure gcc and ld +configureToolchain + :: GhcImplInfo + -> ConfiguredProgram + -> Map String String + -> ProgramDb + -> ProgramDb +configureToolchain _implInfo ghcProg ghcInfo = + addKnownProgram + gccProgram + { programFindLocation = findProg gccProgramName extraGccPath + , programPostConf = configureGcc + } + . addKnownProgram + gppProgram + { programFindLocation = findProg gppProgramName extraGppPath + , programPostConf = configureGpp + } + . addKnownProgram + ldProgram + { programFindLocation = findProg ldProgramName extraLdPath + , programPostConf = \v cp -> + -- Call any existing configuration first and then add any new configuration + configureLd v =<< programPostConf ldProgram v cp + } + . addKnownProgram + arProgram + { programFindLocation = findProg arProgramName extraArPath + } + . addKnownProgram + stripProgram + { programFindLocation = findProg stripProgramName extraStripPath + } + where + compilerDir, base_dir, mingwBinDir :: FilePath + compilerDir = takeDirectory (programPath ghcProg) + base_dir = takeDirectory compilerDir + mingwBinDir = base_dir "mingw" "bin" + isWindows = case buildOS of Windows -> True; _ -> False + binPrefix = "" + + maybeName :: Program -> Maybe FilePath -> String + maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName) + + gccProgramName = maybeName gccProgram mbGccLocation + gppProgramName = maybeName gppProgram mbGppLocation + ldProgramName = maybeName ldProgram mbLdLocation + arProgramName = maybeName arProgram mbArLocation + stripProgramName = maybeName stripProgram mbStripLocation + + mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath] + mkExtraPath mbPath mingwPath + | isWindows = mbDir ++ [mingwPath] + | otherwise = mbDir + where + mbDir = maybeToList . fmap takeDirectory $ mbPath + + extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir + extraGppPath = mkExtraPath mbGppLocation windowsExtraGppDir + extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir + extraArPath = mkExtraPath mbArLocation windowsExtraArDir + extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir + + -- on Windows finding and configuring ghc's gcc & binutils is a bit special + ( windowsExtraGccDir + , windowsExtraGppDir + , windowsExtraLdDir + , windowsExtraArDir + , windowsExtraStripDir + ) = + let b = mingwBinDir binPrefix + in (b, b, b, b, b) + + findProg + :: String + -> [FilePath] + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + findProg progName extraPath v searchpath = + findProgramOnSearchPath v searchpath' progName + where + searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath + + -- Read tool locations from the 'ghc --info' output. Useful when + -- cross-compiling. + mbGccLocation = Map.lookup "C compiler command" ghcInfo + mbGppLocation = Map.lookup "C++ compiler command" ghcInfo + mbLdLocation = Map.lookup "ld command" ghcInfo + mbArLocation = Map.lookup "ar command" ghcInfo + mbStripLocation = Map.lookup "strip command" ghcInfo + + ccFlags = getFlags "C compiler flags" + cxxFlags = getFlags "C++ compiler flags" + -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags" + -- and "Ld Linker flags" to "ld flags" (GHC #4862). + gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags" + ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags" + + -- It appears that GHC 7.6 and earlier encode the tokenized flags as a + -- [String] in these settings whereas later versions just encode the flags as + -- String. + -- + -- We first try to parse as a [String] and if this fails then tokenize the + -- flags ourself. + getFlags :: String -> [String] + getFlags key = + case Map.lookup key ghcInfo of + Nothing -> [] + Just flags + | (flags', "") : _ <- reads flags -> flags' + | otherwise -> tokenizeQuotedWords flags + + configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGcc _v gccProg = do + return + gccProg + { programDefaultArgs = + programDefaultArgs gccProg + ++ ccFlags + ++ gccLinkerFlags + } + + configureGpp :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureGpp _v gppProg = do + return + gppProg + { programDefaultArgs = + programDefaultArgs gppProg + ++ cxxFlags + } + + configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd v ldProg = do + ldProg' <- configureLd' v ldProg + return + ldProg' + { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags + } + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + configureLd' verbosity ldProg = do + ldx <- withTempFile ".c" $ \testcfile testchnd -> + withTempFile ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() { return 0; }" + hClose testchnd + hClose testohnd + runProgram + verbosity + ghcProg + [ "-hide-all-packages" + , "-c" + , testcfile + , "-o" + , testofile + ] + withTempFile ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- + getProgramOutput + verbosity + ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ldProg{programDefaultArgs = ["-x"]} + else return ldProg + +getLanguages + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Language, String)] +getLanguages _ implInfo _ + -- TODO: should be using --supported-languages rather than hard coding + | supportsGHC2024 implInfo = + return + [ (GHC2024, "-XGHC2024") + , (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsGHC2021 implInfo = + return + [ (GHC2021, "-XGHC2021") + , (Haskell2010, "-XHaskell2010") + , (Haskell98, "-XHaskell98") + ] + | supportsHaskell2010 implInfo = + return + [ (Haskell98, "-XHaskell98") + , (Haskell2010, "-XHaskell2010") + ] + | otherwise = return [(Haskell98, "")] + +getGhcInfo + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(String, String)] +getGhcInfo verbosity _implInfo ghcProg = do + xs <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + dieWithException verbosity CantParseGHCOutput + +getExtensions + :: Verbosity + -> GhcImplInfo + -> ConfiguredProgram + -> IO [(Extension, Maybe String)] +getExtensions verbosity implInfo ghcProg = do + str <- + getProgramOutput + verbosity + (suppressOverrideArgs ghcProg) + ["--supported-languages"] + let extStrs = + if reportsNoExt implInfo + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = + [ (ext, Just $ "-X" ++ prettyShow ext) + | Just ext <- map simpleParsec extStrs + ] + extensions1 = + if alwaysNondecIndent implInfo + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + -- Since it was not a proper extension, it could + -- not be turned off, hence we omit a + -- DisableExtension entry here. + + (EnableExtension NondecreasingIndentation, Nothing) + : extensions0 + else extensions0 + return extensions1 + +includePaths + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg p + -> NubListR (SymbolicPath Pkg (Dir Include)) +includePaths lbi bi clbi odir = + toNubListR $ + [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi + , coerceSymbolicPath $ autogenPackageModulesDir lbi + , coerceSymbolicPath odir + ] + -- includes relative to the package + ++ includeDirs bi + -- potential includes generated by `configure' + -- in the build directory + ++ [ buildDir lbi dir + | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi + ] + +componentCcGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCcGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCcOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ ccOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentCxxGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCxxGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptCxxOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ cxxOptions bi + , ghcOptCcProgram = + maybeToFlag $ + programPath + <$> lookupProgram gccProgram (withPrograms lbi) + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentAsmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentAsmGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptAsmOptions = + ( case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-O2"] + ) + ++ ( case withDebugInfo lbi of + NoDebugInfo -> [] + MinimalDebugInfo -> ["-g1"] + NormalDebugInfo -> ["-g"] + MaximalDebugInfo -> ["-g3"] + ) + ++ asmOptions bi + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentJsGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentJsGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptJSppOptions = jsppOptions bi + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptObjDir = toFlag odir + , ghcOptExtra = hcOptions GHC bi + } + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir build) + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let implInfo = getImplInfo $ compiler lbi + in mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptCabal = toFlag True + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ | not (unitIdForExes implInfo) -> mempty + ExeComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + TestComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + BenchComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + FLibComponentLocalBuildInfo{componentUnitId = uid} -> + toFlag (unUnitId uid) + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo + { componentComponentId = cid + , componentInstantiatedWith = insts + } -> + if null insts + then mempty + else toFlag cid + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptNoCode = toFlag $ componentIsIndefinite clbi + , ghcOptHideAllPackages = toFlag True + , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi + , ghcOptSplitSections = toFlag (splitSections lbi) + , ghcOptSplitObjs = toFlag (splitObjs lbi) + , ghcOptSourcePathClear = toFlag True + , ghcOptSourcePath = + toNubListR $ + (hsSourceDirs bi) + ++ [coerceSymbolicPath odir] + ++ [autogenComponentModulesDir lbi clbi] + ++ [autogenPackageModulesDir lbi] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptCppOptions = cppOptions bi + , ghcOptJSppOptions = jsppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [coerceSymbolicPath (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi + , ghcOptObjDir = toFlag $ coerceSymbolicPath odir + , ghcOptHiDir = toFlag $ coerceSymbolicPath odir + , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir (extraCompilationArtifacts makeRelativePathEx "hie")) $ flagHie implInfo + , ghcOptStubDir = toFlag $ coerceSymbolicPath odir + , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi + , ghcOptExtraPath = toNubListR exe_paths + , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)) + , -- Unsupported extensions have already been checked by configure + ghcOptExtensions = toNubListR $ usedExtensions bi + , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi) + } + where + exe_paths = + [ componentBuildDir lbi (targetCLBI exe_tgt) + | uid <- componentExeDeps clbi + , -- TODO: Ugh, localPkgDescr + Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] + ] + +toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation +toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override? +toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation +toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation + +componentCmmGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> SymbolicPath Pkg File + -> GhcOptions +componentCmmGhcOptions verbosity lbi bi clbi odir filename = + mempty + { -- Respect -v0, but don't crank up verbosity on GHC if + -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + ghcOptVerbosity = toFlag (min verbosity normal) + , ghcOptMode = toFlag GhcModeCompile + , ghcOptInputFiles = toNubListR [filename] + , ghcOptCppIncludePath = includePaths lbi bi clbi odir + , ghcOptCppOptions = cppOptions bi + , ghcOptCppIncludes = + toNubListR $ + [autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName] + , ghcOptHideAllPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi + , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi) + , ghcOptDebugInfo = toFlag (withDebugInfo lbi) + , ghcOptExtra = hcOptions GHC bi <> cmmOptions bi + , ghcOptObjDir = toFlag odir + } + +-- | Strip out flags that are not supported in ghci +filterGhciFlags :: [String] -> [String] +filterGhciFlags = filter supported + where + supported ('-' : 'O' : _) = False + supported "-debug" = False + supported "-threaded" = False + supported "-ticky" = False + supported "-eventlog" = False + supported "-prof" = False + supported "-unreg" = False + supported _ = True + +mkGHCiLibName :: UnitId -> String +mkGHCiLibName lib = getHSLibraryName lib <.> "o" + +mkGHCiProfLibName :: UnitId -> String +mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o" + +ghcLookupProperty :: String -> Compiler -> Bool +ghcLookupProperty prop comp = + case Map.lookup prop (compilerProperties comp) of + Just "YES" -> True + _ -> False + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects + :: GhcImplInfo + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Artifacts) + -> String + -> Bool + -> IO [SymbolicPath Pkg File] +getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = "_" ++ wanted_obj_ext ++ "_split" + dirs = + [ pref makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix) + | x <- allLibModules lib clbi + ] + objss <- traverse (getDirectoryContents . i) dirs + let objs = + [ dir makeRelativePathEx obj + | (objs', dir) <- zip objss dirs + , obj <- objs' + , let obj_ext = takeExtension obj + , '.' : wanted_obj_ext == obj_ext + ] + return objs + | otherwise = + return + [ pref makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext) + | x <- allLibModules lib clbi + ] + where + i = interpretSymbolicPathLBI lbi + +-- | Create the required packaged arguments, but filtering out package arguments which +-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files, +-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that +-- in 99% of cases we will include the right `-package` so that the C file finds the right headers. +mkGhcOptPackages + :: Map (PackageName, ComponentName) PromisedComponent + -> ComponentLocalBuildInfo + -> [(OpenUnitId, ModuleRenaming)] +mkGhcOptPackages promisedPkgsMap clbi = + [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids + ] + where + -- Promised deps are going to be simple UnitIds + promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap)) + +substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo +substTopDir topDir ipo = + ipo + { IPI.importDirs = map f (IPI.importDirs ipo) + , IPI.libraryDirs = map f (IPI.libraryDirs ipo) + , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo) + , IPI.includeDirs = map f (IPI.includeDirs ipo) + , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo) + , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo) + , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo) + } + where + f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest + f x = x + +-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let +-- users know that this is the case. See ticket #335. Simply ignoring it is +-- not a good idea, since then ghc and cabal are looking at different sets +-- of package DBs and chaos is likely to ensue. +-- +-- An exception to this is when running cabal from within a `cabal exec` +-- environment. In this case, `cabal exec` will set the +-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set +-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow +-- GHC{,JS}_PACKAGE_PATH. +checkPackageDbEnvVar :: Verbosity -> String -> String -> IO () +checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do + mPP <- lookupEnv packagePathEnvVar + when (isJust mPP) $ do + mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH" + unless (mPP == mcsPP) abort + where + lookupEnv :: String -> IO (Maybe String) + lookupEnv name = + (Just `fmap` getEnv name) + `catchIO` const (return Nothing) + abort = + dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar + _ = callStack -- TODO: output stack when erroring + +profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto +profDetailLevelFlag forLib mpl = + case mpl of + ProfDetailNone -> mempty + ProfDetailDefault + | forLib -> toFlag GhcProfAutoExported + | otherwise -> toFlag GhcProfAutoToplevel + ProfDetailExportedFunctions -> toFlag GhcProfAutoExported + ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel + ProfDetailAllFunctions -> toFlag GhcProfAutoAll + ProfDetailTopLate -> toFlag GhcProfLate + ProfDetailOther _ -> mempty + +-- ----------------------------------------------------------------------------- +-- GHC platform and version strings + +-- | GHC's rendering of its host or target 'Arch' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcArchString :: Arch -> String +ghcArchString PPC = "powerpc" +ghcArchString PPC64 = "powerpc64" +ghcArchString PPC64LE = "powerpc64le" +ghcArchString other = prettyShow other + +-- | GHC's rendering of its host or target 'OS' as used in its platform +-- strings and certain file locations (such as user package db location). +ghcOsString :: OS -> String +ghcOsString Windows = "mingw32" +ghcOsString OSX = "darwin" +ghcOsString Solaris = "solaris2" +ghcOsString Hurd = "gnu" +ghcOsString other = prettyShow other + +-- | GHC's rendering of its platform and compiler version string as used in +-- certain file locations (such as user package db location). +-- For example @x86_64-linux-7.10.4@ +ghcPlatformAndVersionString :: Platform -> Version -> String +ghcPlatformAndVersionString (Platform arch os) version = + intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version] + +-- ----------------------------------------------------------------------------- +-- Constructing GHC environment files + +-- | The kinds of entries we can stick in a @.ghc.environment@ file. +data GhcEnvironmentFileEntry fp + = -- | @-- a comment@ + GhcEnvFileComment String + | -- | @package-id foo-1.0-4fe301a...@ + GhcEnvFilePackageId UnitId + | -- | @global-package-db@, + -- @user-package-db@ or + -- @package-db blah/package.conf.d/@ + GhcEnvFilePackageDb (PackageDBX fp) + | -- | @clear-package-db@ + GhcEnvFileClearPackageDbStack + deriving (Eq, Ord, Show) + +-- | Make entries for a GHC environment file based on a 'PackageDBStack' and +-- a bunch of package (unit) ids. +-- +-- If you need to do anything more complicated then either use this as a basis +-- and add more entries, or just make all the entries directly. +simpleGhcEnvironmentFile + :: PackageDBStackX fp + -> [UnitId] + -> [GhcEnvironmentFileEntry fp] +simpleGhcEnvironmentFile packageDBs pkgids = + GhcEnvFileClearPackageDbStack + : map GhcEnvFilePackageDb packageDBs + ++ map GhcEnvFilePackageId pkgids + +-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory. +-- +-- The 'Platform' and GHC 'Version' are needed as part of the file name. +-- +-- Returns the name of the file written. +writeGhcEnvironmentFile + :: FilePath + -- ^ directory in which to put it + -> Platform + -- ^ the GHC target platform + -> Version + -- ^ the GHC version + -> [GhcEnvironmentFileEntry FilePath] + -- ^ the content + -> IO FilePath +writeGhcEnvironmentFile directory platform ghcversion entries = do + writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries + return envfile + where + envfile = directory ghcEnvironmentFileName platform ghcversion + +-- | The @.ghc.environment-$arch-$os-$ver@ file name +ghcEnvironmentFileName :: Platform -> Version -> FilePath +ghcEnvironmentFileName platform ghcversion = + ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion + +-- | Render a bunch of GHC environment file entries +renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String +renderGhcEnvironmentFile = + unlines . map renderGhcEnvironmentFileEntry + +-- | Render an individual GHC environment file entry +renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String +renderGhcEnvironmentFileEntry entry = case entry of + GhcEnvFileComment comment -> format comment + where + format = intercalate "\n" . map ("--" <++>) . lines + pref <++> "" = pref + pref <++> str = pref ++ " " ++ str + GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid + GhcEnvFilePackageDb pkgdb -> + case pkgdb of + GlobalPackageDB -> "global-package-db" + UserPackageDB -> "user-package-db" + SpecificPackageDB dbfile -> "package-db " ++ dbfile + GhcEnvFileClearPackageDbStack -> "clear-package-db" diff --git a/src/Distribution/Simple/GHCJS.hs b/src/Distribution/Simple/GHCJS.hs --- a/src/Distribution/Simple/GHCJS.hs +++ b/src/Distribution/Simple/GHCJS.hs @@ -1,1826 +1,2116 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE CPP #-} - -module Distribution.Simple.GHCJS ( - getGhcInfo, - configure, - getInstalledPackages, - getInstalledPackagesMonitorFiles, - getPackageDBContents, - buildLib, buildFLib, buildExe, - replLib, replFLib, replExe, - startInterpreter, - installLib, installFLib, installExe, - libAbiHash, - hcPkgInfo, - registerPackage, - componentGhcOptions, - componentCcGhcOptions, - getLibDir, - isDynamic, - getGlobalPackageDB, - pkgRoot, - runCmd, - -- * Constructing and deconstructing GHC environment files - Internal.GhcEnvironmentFileEntry(..), - Internal.simpleGhcEnvironmentFile, - Internal.renderGhcEnvironmentFile, - Internal.writeGhcEnvironmentFile, - Internal.ghcPlatformAndVersionString, - readGhcEnvironmentFile, - parseGhcEnvironmentFile, - ParseErrorExc(..), - -- * Version-specific implementation quirks - getImplInfo, - GhcImplInfo(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC.Internal as Internal -import Distribution.Simple.GHC.ImplInfo -import Distribution.Simple.GHC.EnvironmentParser -import Distribution.PackageDescription.Utils (cabalBug) -import Distribution.PackageDescription as PD -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (InstalledPackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo -import Distribution.Types.ComponentLocalBuildInfo -import qualified Distribution.Simple.Hpc as Hpc -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.Simple.Program -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.Program.Strip as Strip -import Distribution.Simple.Program.GHC -import Distribution.Simple.Setup -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Simple.Compiler -import Distribution.CabalSpecVersion -import Distribution.Version -import Distribution.System -import Distribution.Verbosity -import Distribution.Pretty -import Distribution.Utils.NubList -import Distribution.Utils.Path - -import Control.Monad (msum) -import Data.Char (isLower) -import qualified Data.Map as Map -import System.Directory - ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing - , canonicalizePath, removeFile, renameFile ) -import System.FilePath ( (), (<.>), takeExtension - , takeDirectory, replaceExtension - ,isRelative ) -import qualified System.Info - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb - -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath hcPkgPath conf0 = do - - (ghcjsProg, ghcjsVersion, progdb1) <- - requireProgramVersion verbosity ghcjsProgram - (orLaterVersion (mkVersion [0,1])) - (userMaybeSpecifyPath "ghcjs" hcPath conf0) - - Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) - unless (ghcjsGhcVersion < mkVersion [8,8]) $ - warn verbosity $ - "Unknown/unsupported 'ghc' version detected " - ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): " - ++ programPath ghcjsProg ++ " is based on GHC version " ++ - prettyShow ghcjsGhcVersion - - let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion - - -- This is slightly tricky, we have to configure ghc first, then we use the - -- location of ghc to help find ghc-pkg in the case that the user did not - -- specify the location of ghc-pkg directly: - (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- - requireProgramVersion verbosity ghcjsPkgProgram { - programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg - } - anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) - - Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion - verbosity (programPath ghcjsPkgProg) - - when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " " - ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion - - when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $ - "Version mismatch between ghcjs and ghcjs-pkg: " - ++ programPath ghcjsProg - ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " " - ++ programPath ghcjsPkgProg - ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion - - - -- Likewise we try to find the matching hsc2hs and haddock programs. - let hsc2hsProgram' = hsc2hsProgram { - programFindLocation = - guessHsc2hsFromGhcjsPath ghcjsProg - } - haddockProgram' = haddockProgram { - programFindLocation = - guessHaddockFromGhcjsPath ghcjsProg - } - hpcProgram' = hpcProgram { - programFindLocation = guessHpcFromGhcjsPath ghcjsProg - } - {- - runghcProgram' = runghcProgram { - programFindLocation = guessRunghcFromGhcjsPath ghcjsProg - } -} - progdb3 = addKnownProgram haddockProgram' $ - addKnownProgram hsc2hsProgram' $ - addKnownProgram hpcProgram' $ - {- addKnownProgram runghcProgram' -} progdb2 - - languages <- Internal.getLanguages verbosity implInfo ghcjsProg - extensions <- Internal.getExtensions verbosity implInfo ghcjsProg - - ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg - let ghcInfoMap = Map.fromList ghcjsInfo - - let comp = Compiler { - compilerId = CompilerId GHCJS ghcjsVersion, - compilerAbiTag = AbiTag $ - "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion), - compilerCompat = [CompilerId GHC ghcjsGhcVersion], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = ghcInfoMap - } - compPlatform = Internal.targetPlatform ghcjsInfo - return (comp, compPlatform, progdb3) - -guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram - -guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram - -guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity - -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath])) -guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram - -guessHpcFromGhcjsPath :: ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram - - -guessToolFromGhcjsPath :: Program -> ConfiguredProgram - -> Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])) -guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath - = do let toolname = programName tool - given_path = programPath ghcjsProg - given_dir = takeDirectory given_path - real_path <- canonicalizePath given_path - let real_dir = takeDirectory real_path - versionSuffix path = takeVersionSuffix (dropExeExtension path) - given_suf = versionSuffix given_path - real_suf = versionSuffix real_path - guessNormal dir = dir toolname <.> exeExtension buildPlatform - guessGhcjs dir = dir (toolname ++ "-ghcjs") - <.> exeExtension buildPlatform - guessGhcjsVersioned dir suf = dir (toolname ++ "-ghcjs" ++ suf) - <.> exeExtension buildPlatform - guessVersioned dir suf = dir (toolname ++ suf) - <.> exeExtension buildPlatform - mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir] - | otherwise = [guessGhcjsVersioned dir suf, - guessVersioned dir suf, - guessGhcjs dir, - guessNormal dir] - guesses = mkGuesses given_dir given_suf ++ - if real_path == given_path - then [] - else mkGuesses real_dir real_suf - info verbosity $ "looking for tool " ++ toolname - ++ " near compiler in " ++ given_dir - debug verbosity $ "candidate locations: " ++ show guesses - exists <- traverse doesFileExist guesses - case [ file | (file, True) <- zip guesses exists ] of - -- If we can't find it near ghc, fall back to the usual - -- method. - [] -> programFindLocation tool verbosity searchpath - (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp - let lookedAt = map fst - . takeWhile (\(_file, exist) -> not exist) - $ zip guesses exists - return (Just (fp, lookedAt)) - - where takeVersionSuffix :: FilePath -> String - takeVersionSuffix = takeWhileEndLE isSuffixChar - - isSuffixChar :: Char -> Bool - isSuffixChar c = isDigit c || c == '.' || c == '-' - -getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] -getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg - where - version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg - implInfo = ghcVersionImplInfo version - --- | Given a single package DB, return all installed packages. -getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb - -> IO InstalledPackageIndex -getPackageDBContents verbosity packagedb progdb = do - pkgss <- getInstalledPackages' verbosity [packagedb] progdb - toPackageIndex verbosity pkgss progdb - --- | Given a package DB stack, return all installed packages. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = do - checkPackageDbEnvVar verbosity - checkPackageDbStack verbosity packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs progdb - index <- toPackageIndex verbosity pkgss progdb - return $! index - -toPackageIndex :: Verbosity - -> [(PackageDB, [InstalledPackageInfo])] - -> ProgramDb - -> IO InstalledPackageIndex -toPackageIndex verbosity pkgss progdb = do - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it. - topDir <- getLibDir' verbosity ghcjsProg - let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! (mconcat indices) - - where - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - -getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath -getLibDir verbosity lbi = - dropWhileEndLE isSpace `fmap` - getDbProgramOutput verbosity ghcjsProgram - (withPrograms lbi) ["--print-libdir"] - -getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath -getLibDir' verbosity ghcjsProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcjsProg ["--print-libdir"] - - --- | Return the 'FilePath' to the global GHC package database. -getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath -getGlobalPackageDB verbosity ghcProg = - dropWhileEndLE isSpace `fmap` - getProgramOutput verbosity ghcProg ["--print-global-package-db"] - --- | Return the 'FilePath' to the per-user GHC package database. -getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath -getUserPackageDB _verbosity ghcjsProg platform = do - -- It's rather annoying that we have to reconstruct this, because ghc - -- hides this information from us otherwise. But for certain use cases - -- like change monitoring it really can't remain hidden. - appdir <- getAppUserDataDirectory "ghcjs" - return (appdir platformAndVersion packageConfFileName) - where - platformAndVersion = Internal.ghcPlatformAndVersionString - platform ghcjsVersion - packageConfFileName = "package.conf.d" - ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg - -checkPackageDbEnvVar :: Verbosity -> IO () -checkPackageDbEnvVar verbosity = - Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" - -checkPackageDbStack :: Verbosity -> PackageDBStack -> IO () -checkPackageDbStack _ (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack verbosity rest - | GlobalPackageDB `notElem` rest = - die' verbosity $ "With current ghc versions the global package db is always used " - ++ "and must be listed first. This ghc limitation may be lifted in " - ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977" -checkPackageDbStack verbosity _ = - die' verbosity $ "If the global package db is specified, it must be " - ++ "specified first and cannot be specified multiple times" - -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs progdb = - sequenceA - [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb - return (packagedb, pkgs) - | packagedb <- packagedbs ] - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackagesMonitorFiles :: Verbosity -> Platform - -> ProgramDb - -> [PackageDB] - -> IO [FilePath] -getInstalledPackagesMonitorFiles verbosity platform progdb = - traverse getPackageDBPath - where - getPackageDBPath :: PackageDB -> IO FilePath - getPackageDBPath GlobalPackageDB = - selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg - - getPackageDBPath UserPackageDB = - selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform - - getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path - - -- GHC has old style file dbs, and new style directory dbs. - -- Note that for dir style dbs, we only need to monitor the cache file, not - -- the whole directory. The ghc program itself only reads the cache file - -- so it's safe to only monitor this one file. - selectMonitorFile path = do - isFileStyle <- doesFileExist path - if isFileStyle then return path - else return (path "package.cache") - - ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb - - -toJSLibName :: String -> String -toJSLibName lib - | takeExtension lib `elem` [".dll",".dylib",".so"] - = replaceExtension lib "js_so" - | takeExtension lib == ".a" = replaceExtension lib "js_a" - | otherwise = lib <.> "js_a" - --- ----------------------------------------------------------------------------- --- Building a library - -buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo - -> IO () -buildLib = buildOrReplLib Nothing - -replLib :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -replLib = buildOrReplLib . Just - -buildOrReplLib :: Maybe [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Library - -> ComponentLocalBuildInfo -> IO () -buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do - let uid = componentUnitId clbi - libTargetDir = componentBuildDir lbi clbi - whenVanillaLib forceVanilla = - when (forceVanilla || withVanillaLib lbi) - whenProfLib = when (withProfLib lbi) - whenSharedLib forceShared = - when (forceShared || withSharedLib lbi) - whenStaticLib forceStatic = - when (forceStatic || withStaticLib lbi) - -- whenGHCiLib = when (withGHCiLib lbi) - forRepl = maybe False (const True) mReplFlags - -- ifReplLib = when forRepl - comp = compiler lbi - implInfo = getImplInfo comp - platform@(Platform _hostArch _hostOS) = hostPlatform lbi - has_code = not (componentIsIndefinite clbi) - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let runGhcjsProg = runGHC verbosity ghcjsProg comp platform - - let libBi = libBuildInfo lib - - -- fixme flags shouldn't depend on ghcjs being dynamic or not - let isGhcjsDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - doingTH = usesTemplateHaskellOrQQ libBi - forceVanillaLib = doingTH && not isGhcjsDynamic - forceSharedLib = doingTH && isGhcjsDynamic - -- TH always needs default libs, even when building for profiling - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = libCoverage lbi - -- TODO: Historically HPC files have been put into a directory which - -- has the package name. I'm going to avoid changing this for - -- now, but it would probably be better for this to be the - -- component ID instead... - pkg_name = prettyShow (PD.package pkg_descr) - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | forRepl = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name - | otherwise = mempty - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? - let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) - jsSrcs = jsSources libBi - cObjs = map (`replaceExtension` objExtension) cLikeFiles - baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir - linkJsLibOpts = mempty { - ghcOptExtra = - [ "-link-js-lib" , getHSLibraryName uid - , "-js-lib-outputdir", libTargetDir ] ++ - jsSrcs - } - vanillaOptsNoJsLib = baseOpts `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptNumJobs = numJobs, - ghcOptInputModules = toNubListR $ allLibModules lib clbi, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts - - profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - -- ghcOptHiSuffix = toFlag "p_hi", - -- ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Prof - } - - sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - -- ghcOptHiSuffix = toFlag "dyn_hi", - -- ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - vanillaSharedOpts = vanillaOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "js_dyn_hi", - ghcOptDynObjSuffix = toFlag "js_dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - - unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ - do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) - shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) - useDynToo = dynamicTooSupported && - (forceVanillaLib || withVanillaLib lbi) && - (forceSharedLib || withSharedLib lbi) && - null (hcSharedOptions GHC libBi) - if not has_code - then vanilla - else - if useDynToo - then do - runGhcjsProg vanillaSharedOpts - case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of - (Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> - -- When the vanilla and shared library builds are done - -- in one pass, only one set of HPC module interfaces - -- are generated. This set should suffice for both - -- static and dynamically linked executables. We copy - -- the modules interfaces so they are available under - -- both ways. - copyDirectoryRecursive verbosity dynDir vanillaDir - _ -> return () - else if isGhcjsDynamic - then do shared; vanilla - else do vanilla; shared - whenProfLib (runGhcjsProg profOpts) - - -- Build any C++ sources separately. - {- - unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCxxOpts = if isGhcjsDynamic - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCxxOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded cxxOpts = do - needsRecomp <- checkNeedsRecompilation filename cxxOpts - when needsRecomp $ runGhcjsProg cxxOpts - runGhcProgIfNeeded vanillaCxxOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) - | filename <- cxxSources libBi] - - ifReplLib $ do - when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" - ifReplLib (runGhcjsProg replOpts) --} - -- build any C sources - -- TODO: Add support for S and CMM files. - {- - unless (not has_code || null (cSources libBi) || not nativeToo) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi libBi clbi libTargetDir filename - vanillaCcOpts = if isGhcjsDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptObjSuffix = toFlag "p_o" - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptObjSuffix = toFlag "dyn_o" - } - odir = fromFlag (ghcOptObjDir vanillaCcOpts) - createDirectoryIfMissingVerbose verbosity True odir - let runGhcProgIfNeeded ccOpts = do - needsRecomp <- checkNeedsRecompilation filename ccOpts - when needsRecomp $ runGhcjsProg ccOpts - runGhcProgIfNeeded vanillaCcOpts - unless forRepl $ - whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) - unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) - | filename <- cSources libBi] --} - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - - -- link: - - when has_code . when False {- fixme nativeToo -} . unless forRepl $ do - info verbosity "Linking..." - let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) - (cSources libBi ++ cxxSources libBi) - compiler_id = compilerId (compiler lbi) - sharedLibFilePath = libTargetDir mkSharedLibName (hostPlatform lbi) compiler_id uid - staticLibFilePath = libTargetDir mkStaticLibName (hostPlatform lbi) compiler_id uid - - let stubObjs = [] - stubSharedObjs = [] - -{- - stubObjs <- catMaybes <$> sequenceA - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubProfObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] - stubSharedObjs <- catMaybes <$> sequenceA - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files - , x <- allLibModules lib clbi ] --} - hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir objExtension True - hSharedObjs <- - if withSharedLib lbi - then Internal.getHaskellObjects implInfo lib lbi clbi - libTargetDir ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - rpaths <- getRPaths lbi clbi - - let staticObjectFiles = - hObjs - ++ map (libTargetDir ) cObjs - ++ stubObjs - dynamicObjectFiles = - hSharedObjs - ++ map (libTargetDir ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - mempty { - ghcOptShared = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptInputFiles = toNubListR dynamicObjectFiles, - ghcOptOutputFile = toFlag sharedLibFilePath, - ghcOptExtra = hcSharedOptions GHC libBi, - -- For dynamic libs, Mac OS/X needs to know the install location - -- at build time. This only applies to GHC < 7.8 - see the - -- discussion in #1660. - {- - ghcOptDylibName = if hostOS == OSX - && ghcVersion < mkVersion [7,8] - then toFlag sharedLibInstallPath - else mempty, -} - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, - ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, - ghcOptLinkFrameworkDirs = - toNubListR $ PD.extraFrameworkDirs libBi, - ghcOptRPaths = rpaths - } - ghcStaticLinkArgs = - mempty { - ghcOptStaticLib = toFlag True, - ghcOptInputFiles = toNubListR staticObjectFiles, - ghcOptOutputFile = toFlag staticLibFilePath, - ghcOptExtra = hcStaticOptions GHC libBi, - ghcOptHideAllPackages = toFlag True, - ghcOptNoAutoLinkPackages = toFlag True, - ghcOptPackageDBs = withPackageDB lbi, - ghcOptThisUnitId = case clbi of - LibComponentLocalBuildInfo { componentCompatPackageKey = pk } - -> toFlag pk - _ -> mempty, - ghcOptThisComponentId = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> - if null insts - then mempty - else toFlag (componentComponentId clbi) - _ -> mempty, - ghcOptInstantiatedWith = case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } - -> insts - _ -> [], - ghcOptPackages = toNubListR $ - Internal.mkGhcOptPackages clbi , - ghcOptLinkLibs = extraLibs libBi, - ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi - } - - info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) -{- - whenVanillaLib False $ do - Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciLibFilePath staticObjectFiles - -} -{- - whenProfLib $ do - Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles - whenGHCiLib $ do - (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) - Ld.combineObjectFiles verbosity lbi ldProg - ghciProfLibFilePath profObjectFiles --} - whenSharedLib False $ - runGhcjsProg ghcSharedLinkArgs - - whenStaticLib False $ - runGhcjsProg ghcStaticLinkArgs - --- | Start a REPL without loading any source files. -startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform - -> PackageDBStack -> IO () -startInterpreter verbosity progdb comp platform packageDBs = do - let replOpts = mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptPackageDBs = packageDBs - } - checkPackageDbStack verbosity packageDBs - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb - runGHC verbosity ghcjsProg comp platform replOpts - --- ----------------------------------------------------------------------------- --- Building an executable or foreign library - --- | Build a foreign library -buildFLib - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> ForeignLib -> ComponentLocalBuildInfo -> IO () -buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib - -replFLib - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> ForeignLib - -> ComponentLocalBuildInfo -> IO () -replFLib replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplFLib replFlags - --- | Build an executable with GHC. --- -buildExe - :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe - -replExe - :: [String] -> Verbosity - -> Cabal.Flag (Maybe Int) -> PackageDescription - -> LocalBuildInfo -> Executable - -> ComponentLocalBuildInfo -> IO () -replExe replFlags v njobs pkg lbi = - gbuild v njobs pkg lbi . GReplExe replFlags - --- | Building an executable, starting the REPL, and building foreign --- libraries are all very similar and implemented in 'gbuild'. The --- 'GBuildMode' distinguishes between the various kinds of operation. -data GBuildMode = - GBuildExe Executable - | GReplExe [String] Executable - | GBuildFLib ForeignLib - | GReplFLib [String] ForeignLib - -gbuildInfo :: GBuildMode -> BuildInfo -gbuildInfo (GBuildExe exe) = buildInfo exe -gbuildInfo (GReplExe _ exe) = buildInfo exe -gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib -gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib - -gbuildName :: GBuildMode -> String -gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe -gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe -gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib -gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib - -gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String -gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe -gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib -gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib - -exeTargetName :: Platform -> Executable -> String -exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform - --- | Target name for a foreign library (the actual file name) --- --- We do not use mkLibName and co here because the naming for foreign libraries --- is slightly different (we don't use "_p" or compiler version suffices, and we --- don't want the "lib" prefix on Windows). --- --- TODO: We do use `dllExtension` and co here, but really that's wrong: they --- use the OS used to build cabal to determine which extension to use, rather --- than the target OS (but this is wrong elsewhere in Cabal as well). -flibTargetName :: LocalBuildInfo -> ForeignLib -> String -flibTargetName lbi flib = - case (os, foreignLibType flib) of - (Windows, ForeignLibNativeShared) -> nm <.> "dll" - (Windows, ForeignLibNativeStatic) -> nm <.> "lib" - (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt - (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) - (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) - (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" - where - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - -- If a foreign lib foo has lib-version-info 5:1:2 or - -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 - -- Libtool's version-info data is translated into library versions in a - -- nontrivial way: so refer to libtool documentation. - versionedExt :: String - versionedExt = - let nums = foreignLibVersion flib os - in foldl (<.>) "so" (map show nums) - --- | Name for the library when building. --- --- If the `lib-version-info` field or the `lib-version-linux` field of --- a foreign library target is set, we need to incorporate that --- version into the SONAME field. --- --- If a foreign library foo has lib-version-info 5:1:2, it should be --- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. --- However, GHC does not allow overriding soname by setting linker --- options, as it sets a soname of its own (namely the output --- filename), after the user-supplied linker options. Hence, we have --- to compile the library with the soname as its filename. We rename --- the compiled binary afterwards. --- --- This method allows to adjust the name of the library at build time --- such that the correct soname can be set. -flibBuildName :: LocalBuildInfo -> ForeignLib -> String -flibBuildName lbi flib - -- On linux, if a foreign-library has version data, the first digit is used - -- to produce the SONAME. - | (os, foreignLibType flib) == - (Linux, ForeignLibNativeShared) - = let nums = foreignLibVersion flib os - in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) - | otherwise = flibTargetName lbi flib - where - os :: OS - os = let (Platform _ os') = hostPlatform lbi - in os' - - nm :: String - nm = unUnqualComponentName $ foreignLibName flib - -gbuildIsRepl :: GBuildMode -> Bool -gbuildIsRepl (GBuildExe _) = False -gbuildIsRepl (GReplExe _ _) = True -gbuildIsRepl (GBuildFLib _) = False -gbuildIsRepl (GReplFLib _ _) = True - -gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool -gbuildNeedDynamic lbi bm = - case bm of - GBuildExe _ -> withDynExe lbi - GReplExe _ _ -> withDynExe lbi - GBuildFLib flib -> withDynFLib flib - GReplFLib _ flib -> withDynFLib flib - where - withDynFLib flib = - case foreignLibType flib of - ForeignLibNativeShared -> - ForeignLibStandalone `notElem` foreignLibOptions flib - ForeignLibNativeStatic -> - False - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -gbuildModDefFiles :: GBuildMode -> [FilePath] -gbuildModDefFiles (GBuildExe _) = [] -gbuildModDefFiles (GReplExe _ _) = [] -gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib -gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib - --- | "Main" module name when overridden by @ghc-options: -main-is ...@ --- or 'Nothing' if no @-main-is@ flag could be found. --- --- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. -exeMainModuleName :: Executable -> Maybe ModuleName -exeMainModuleName Executable{buildInfo = bnfo} = - -- GHC honors the last occurrence of a module name updated via -main-is - -- - -- Moreover, -main-is when parsed left-to-right can update either - -- the "Main" module name, or the "main" function name, or both, - -- see also 'decodeMainIsArg'. - msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts - where - ghcopts = hcOptions GHC bnfo - - findIsMainArgs [] = [] - findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest - findIsMainArgs (_:rest) = findIsMainArgs rest - --- | Decode argument to '-main-is' --- --- Returns 'Nothing' if argument set only the function name. --- --- This code has been stolen/refactored from GHC's DynFlags.setMainIs --- function. The logic here is deliberately imperfect as it is --- intended to be bug-compatible with GHC's parser. See discussion in --- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. -decodeMainIsArg :: String -> Maybe ModuleName -decodeMainIsArg arg - | headOf main_fn isLower - -- The arg looked like "Foo.Bar.baz" - = Just (ModuleName.fromString main_mod) - | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" - = Just (ModuleName.fromString arg) - | otherwise -- The arg looked like "baz" - = Nothing - where - headOf :: String -> (Char -> Bool) -> Bool - headOf str pred' = any pred' (safeHead str) - - (main_mod, main_fn) = splitLongestPrefix arg (== '.') - - splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) - splitLongestPrefix str pred' - | null r_pre = (str, []) - | otherwise = (reverse (safeTail r_pre), reverse r_suf) - -- 'safeTail' drops the char satisfying 'pred' - where (r_suf, r_pre) = break pred' (reverse str) - - --- | A collection of: --- * C input files --- * C++ input files --- * GHC input files --- * GHC input modules --- --- Used to correctly build and link sources. -data BuildSources = BuildSources { - cSourcesFiles :: [FilePath], - cxxSourceFiles :: [FilePath], - inputSourceFiles :: [FilePath], - inputSourceModules :: [ModuleName] - } - --- | Locate and return the 'BuildSources' required to build and link. -gbuildSources :: Verbosity - -> CabalSpecVersion - -> FilePath - -> GBuildMode - -> IO BuildSources -gbuildSources verbosity specVer tmpDir bm = - case bm of - GBuildExe exe -> exeSources exe - GReplExe _ exe -> exeSources exe - GBuildFLib flib -> return $ flibSources flib - GReplFLib _ flib -> return $ flibSources flib - where - exeSources :: Executable -> IO BuildSources - exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do - main <- findFileEx verbosity (tmpDir : map getSymbolicPath (hsSourceDirs bnfo)) modPath - let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe - otherModNames = exeModules exe - - if isHaskell main - then - if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) - then do - -- The cabal manual clearly states that `other-modules` is - -- intended for non-main modules. However, there's at least one - -- important package on Hackage (happy-1.19.5) which - -- violates this. We workaround this here so that we don't - -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which - -- would result in GHC complaining about duplicate Main - -- modules. - -- - -- Finally, we only enable this workaround for - -- specVersion < 2, as 'cabal-version:>=2.0' cabal files - -- have no excuse anymore to keep doing it wrong... ;-) - warn verbosity $ "Enabling workaround for Main module '" - ++ prettyShow mainModName - ++ "' listed in 'other-modules' illegally!" - - return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = filter (/= mainModName) $ exeModules exe - } - - else return BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [main], - inputSourceModules = exeModules exe - } - else let (csf, cxxsf) - | isCxx main = ( cSources bnfo, main : cxxSources bnfo) - -- if main is not a Haskell source - -- and main is not a C++ source - -- then we assume that it is a C source - | otherwise = (main : cSources bnfo, cxxSources bnfo) - - in return BuildSources { - cSourcesFiles = csf, - cxxSourceFiles = cxxsf, - inputSourceFiles = [], - inputSourceModules = exeModules exe - } - - flibSources :: ForeignLib -> BuildSources - flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = - BuildSources { - cSourcesFiles = cSources bnfo, - cxxSourceFiles = cxxSources bnfo, - inputSourceFiles = [], - inputSourceModules = foreignLibModules flib - } - - isHaskell :: FilePath -> Bool - isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] - - isCxx :: FilePath -> Bool - isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] - --- | Generic build function. See comment for 'GBuildMode'. -gbuild :: Verbosity -> Cabal.Flag (Maybe Int) - -> PackageDescription -> LocalBuildInfo - -> GBuildMode -> ComponentLocalBuildInfo -> IO () -gbuild verbosity numJobs pkg_descr lbi bm clbi = do - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - let replFlags = case bm of - GReplExe flags _ -> flags - GReplFLib flags _ -> flags - GBuildExe{} -> mempty - GBuildFLib{} -> mempty - comp = compiler lbi - platform = hostPlatform lbi - implInfo = getImplInfo comp - runGhcProg = runGHC verbosity ghcjsProg comp platform - - let (bnfo, threaded) = case bm of - GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) - _ -> (gbuildInfo bm, False) - - -- the name that GHC really uses (e.g., with .exe on Windows for executables) - let targetName = gbuildTargetName lbi bm - let targetDir = buildDir lbi (gbuildName bm) - let tmpDir = targetDir (gbuildName bm ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True tmpDir - - -- TODO: do we need to put hs-boot files into place for mutually recursive - -- modules? FIX: what about exeName.hi-boot? - - -- Determine if program coverage should be enabled and if so, what - -- '-hpcdir' should be. - let isCoverageEnabled = exeCoverage lbi - distPref = fromFlag $ configDistPref $ configFlags lbi - hpcdir way - | gbuildIsRepl bm = mempty -- HPC is not supported in ghci - | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm) - | otherwise = mempty - - rpaths <- getRPaths lbi clbi - buildSources <- gbuildSources verbosity (specVersion pkg_descr) tmpDir bm - - let cSrcs = cSourcesFiles buildSources - cxxSrcs = cxxSourceFiles buildSources - inputFiles = inputSourceFiles buildSources - inputModules = inputSourceModules buildSources - isGhcDynamic = isDynamic comp - dynamicTooSupported = supportsDynamicToo comp - cObjs = map (`replaceExtension` objExtension) cSrcs - cxxObjs = map (`replaceExtension` objExtension) cxxSrcs - needDynamic = gbuildNeedDynamic lbi bm - needProfiling = withProfExe lbi - - -- build executables - baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir) - `mappend` mempty { - ghcOptMode = toFlag GhcModeMake, - ghcOptInputFiles = toNubListR inputFiles, - ghcOptInputModules = toNubListR inputModules - } - staticOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticOnly, - ghcOptHPCDir = hpcdir Hpc.Vanilla - } - profOpts = baseOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag False - (withProfExeDetail lbi), - ghcOptHiSuffix = toFlag "p_hi", - ghcOptObjSuffix = toFlag "p_o", - ghcOptExtra = hcProfOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Prof - } - dynOpts = baseOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - -- TODO: Does it hurt to set -fPIC for executables? - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bnfo, - ghcOptHPCDir = hpcdir Hpc.Dyn - } - dynTooOpts = staticOpts `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcStaticAndDynamic, - ghcOptDynHiSuffix = toFlag "dyn_hi", - ghcOptDynObjSuffix = toFlag "dyn_o", - ghcOptHPCDir = hpcdir Hpc.Dyn - } - linkerOpts = mempty { - ghcOptLinkOptions = PD.ldOptions bnfo, - ghcOptLinkLibs = extraLibs bnfo, - ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo, - ghcOptLinkFrameworks = toNubListR $ - PD.frameworks bnfo, - ghcOptLinkFrameworkDirs = toNubListR $ - PD.extraFrameworkDirs bnfo, - ghcOptInputFiles = toNubListR - [tmpDir x | x <- cObjs ++ cxxObjs] - } - dynLinkerOpts = mempty { - ghcOptRPaths = rpaths - } - replOpts = baseOpts { - ghcOptExtra = Internal.filterGhciFlags - (ghcOptExtra baseOpts) - <> replFlags - } - -- For a normal compile we do separate invocations of ghc for - -- compiling as for linking. But for repl we have to do just - -- the one invocation, so that one has to include all the - -- linker stuff too, like -l flags and any .o files from C - -- files etc. - `mappend` linkerOpts - `mappend` mempty { - ghcOptMode = toFlag GhcModeInteractive, - ghcOptOptimisation = toFlag GhcNoOptimisation - } - commonOpts | needProfiling = profOpts - | needDynamic = dynOpts - | otherwise = staticOpts - compileOpts | useDynToo = dynTooOpts - | otherwise = commonOpts - withStaticExe = not needProfiling && not needDynamic - - -- For building exe's that use TH with -prof or -dynamic we actually have - -- to build twice, once without -prof/-dynamic and then again with - -- -prof/-dynamic. This is because the code that TH needs to run at - -- compile time needs to be the vanilla ABI so it can be loaded up and run - -- by the compiler. - -- With dynamic-by-default GHC the TH object files loaded at compile-time - -- need to be .dyn_o instead of .o. - doingTH = usesTemplateHaskellOrQQ bnfo - -- Should we use -dynamic-too instead of compiling twice? - useDynToo = dynamicTooSupported && isGhcDynamic - && doingTH && withStaticExe - && null (hcSharedOptions GHC bnfo) - compileTHOpts | isGhcDynamic = dynOpts - | otherwise = staticOpts - compileForTH - | gbuildIsRepl bm = False - | useDynToo = False - | isGhcDynamic = doingTH && (needProfiling || withStaticExe) - | otherwise = doingTH && (needProfiling || needDynamic) - - -- Build static/dynamic object files for TH, if needed. - when compileForTH $ - runGhcProg compileTHOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- Do not try to build anything if there are no input files. - -- This can happen if the cabal file ends up with only cSrcs - -- but no Haskell modules. - unless ((null inputFiles && null inputModules) - || gbuildIsRepl bm) $ - runGhcProg compileOpts { ghcOptNoLink = toFlag True - , ghcOptNumJobs = numJobs } - - -- build any C++ sources - unless (null cxxSrcs) $ do - info verbosity "Building C++ Sources..." - sequence_ - [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCxxOpts = if isGhcDynamic - -- Dynamic GHC requires C++ sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCxxOpts { ghcOptFPic = toFlag True } - else baseCxxOpts - profCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCxxOpts = vanillaCxxOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCxxOpts - | needDynamic = sharedCxxOpts - | otherwise = vanillaCxxOpts - -- TODO: Placing all Haskell, C, & C++ objects in a single directory - -- Has the potential for file collisions. In general we would - -- consider this a user error. However, we should strive to - -- add a warning if this occurs. - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cxxSrcs ] - - -- build any C sources - unless (null cSrcs) $ do - info verbosity "Building C Sources..." - sequence_ - [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo - lbi bnfo clbi tmpDir filename - vanillaCcOpts = if isGhcDynamic - -- Dynamic GHC requires C sources to be built - -- with -fPIC for REPL to work. See #2207. - then baseCcOpts { ghcOptFPic = toFlag True } - else baseCcOpts - profCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptProfilingMode = toFlag True - } - sharedCcOpts = vanillaCcOpts `mappend` mempty { - ghcOptFPic = toFlag True, - ghcOptDynLinkMode = toFlag GhcDynamicOnly - } - opts | needProfiling = profCcOpts - | needDynamic = sharedCcOpts - | otherwise = vanillaCcOpts - odir = fromFlag (ghcOptObjDir opts) - createDirectoryIfMissingVerbose verbosity True odir - needsRecomp <- checkNeedsRecompilation filename opts - when needsRecomp $ - runGhcProg opts - | filename <- cSrcs ] - - -- TODO: problem here is we need the .c files built first, so we can load them - -- with ghci, but .c files can depend on .h files generated by ghc by ffi - -- exports. - case bm of - GReplExe _ _ -> runGhcProg replOpts - GReplFLib _ _ -> runGhcProg replOpts - GBuildExe _ -> do - let linkOpts = commonOpts - `mappend` linkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag (null inputFiles) - } - `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) - - info verbosity "Linking..." - -- Work around old GHCs not relinking in this - -- situation, see #3294 - let target = targetDir targetName - when (compilerVersion comp < mkVersion [7,7]) $ do - e <- doesFileExist target - when e (removeFile target) - runGhcProg linkOpts { ghcOptOutputFile = toFlag target } - GBuildFLib flib -> do - let rtsInfo = extractRtsInfo lbi - rtsOptLinkLibs = [ - if needDynamic - then if threaded - then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) - else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) - else if threaded - then statRtsThreadedLib (rtsStaticInfo rtsInfo) - else statRtsVanillaLib (rtsStaticInfo rtsInfo) - ] - linkOpts = case foreignLibType flib of - ForeignLibNativeShared -> - commonOpts - `mappend` linkerOpts - `mappend` dynLinkerOpts - `mappend` mempty { - ghcOptLinkNoHsMain = toFlag True, - ghcOptShared = toFlag True, - ghcOptLinkLibs = rtsOptLinkLibs, - ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo, - ghcOptFPic = toFlag True, - ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm - } - -- See Note [RPATH] - `mappend` ifNeedsRPathWorkaround lbi mempty { - ghcOptLinkOptions = ["-Wl,--no-as-needed"] - , ghcOptLinkLibs = ["ffi"] - } - ForeignLibNativeStatic -> - -- this should be caught by buildFLib - -- (and if we do implement this, we probably don't even want to call - -- ghc here, but rather Ar.createArLibArchive or something) - cabalBug "static libraries not yet implemented" - ForeignLibTypeUnknown -> - cabalBug "unknown foreign lib type" - -- We build under a (potentially) different filename to set a - -- soname on supported platforms. See also the note for - -- @flibBuildName@. - info verbosity "Linking..." - let buildName = flibBuildName lbi flib - runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir buildName) } - renameFile (targetDir buildName) (targetDir targetName) - -{- -Note [RPATH] -~~~~~~~~~~~~ - -Suppose that the dynamic library depends on `base`, but not (directly) on -`integer-gmp` (which, however, is a dependency of `base`). We will link the -library as - - gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ... - -However, on systems (like Ubuntu) where the linker gets called with `-as-needed` -by default, the linker will notice that `integer-gmp` isn't actually a direct -dependency and hence omit the link. - -Then when we attempt to link a C program against this dynamic library, the -_static_ linker will attempt to verify that all symbols can be resolved. The -dynamic library itself does not require any symbols from `integer-gmp`, but -`base` does. In order to verify that the symbols used by `base` can be -resolved, the static linker needs to be able to _find_ integer-gmp. - -Finding the `base` dependency is simple, because the dynamic elf header -(`readelf -d`) for the library that we have created looks something like - - (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so] - (RPATH) Library rpath: [/path/to/base-4.7.0.2:...] - -However, when it comes to resolving the dependency on `integer-gmp`, it needs -to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this -looks something like - - (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so] - (RPATH) Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...] - -This specifies the location of `integer-gmp` _in terms of_ the location of base -(using the `$ORIGIN`) variable. But here's the crux: when the static linker -attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE -`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive). -As a consequence, it will not be able to resolve the symbols and report the -missing symbols as errors, _even though the dynamic linker **would** be able to -resolve these symbols_. We can tell the static linker not to report these -errors by using `--unresolved-symbols=ignore-all` and all will be fine when we -run the program ([(indeed, this is what the gold linker -does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes -the resulting library more difficult to use. - -Instead what we can do is make sure that the generated dynamic library has -explicit top-level dependencies on these libraries. This means that the static -linker knows where to find them, and when we have transitive dependencies on -the same libraries the linker will only load them once, so we avoid needing to -look at the `RPATH` of our dependencies. We can do this by passing -`--no-as-needed` to the linker, so that it doesn't omit any libraries. - -Note that on older ghc (7.6 and before) the Haskell libraries don't have an -RPATH set at all, which makes it even more important that we make these -top-level dependencies. - -Finally, we have to explicitly link against `libffi` for the same reason. For -newer ghc this _happens_ to be unnecessary on many systems because `libffi` is -a library which is not specific to GHC, and when the static linker verifies -that all symbols can be resolved it will find the `libffi` that is globally -installed (completely independent from ghc). Of course, this may well be the -_wrong_ version of `libffi`, but it's quite possible that symbol resolution -happens to work. This is of course the wrong approach, which is why we link -explicitly against `libffi` so that we will find the _right_ version of -`libffi`. --} - --- | Do we need the RPATH workaround? --- --- See Note [RPATH]. -ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a -ifNeedsRPathWorkaround lbi a = - case hostPlatform lbi of - Platform _ Linux -> a - _otherwise -> mempty - -data DynamicRtsInfo = DynamicRtsInfo { - dynRtsVanillaLib :: FilePath - , dynRtsThreadedLib :: FilePath - , dynRtsDebugLib :: FilePath - , dynRtsEventlogLib :: FilePath - , dynRtsThreadedDebugLib :: FilePath - , dynRtsThreadedEventlogLib :: FilePath - } - -data StaticRtsInfo = StaticRtsInfo { - statRtsVanillaLib :: FilePath - , statRtsThreadedLib :: FilePath - , statRtsDebugLib :: FilePath - , statRtsEventlogLib :: FilePath - , statRtsThreadedDebugLib :: FilePath - , statRtsThreadedEventlogLib :: FilePath - , statRtsProfilingLib :: FilePath - , statRtsThreadedProfilingLib :: FilePath - } - -data RtsInfo = RtsInfo { - rtsDynamicInfo :: DynamicRtsInfo - , rtsStaticInfo :: StaticRtsInfo - , rtsLibPaths :: [FilePath] - } - --- | Extract (and compute) information about the RTS library --- --- TODO: This hardcodes the name as @HSrts-ghc@. I don't know if we can --- find this information somewhere. We can lookup the 'hsLibraries' field of --- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which --- doesn't really help. -extractRtsInfo :: LocalBuildInfo -> RtsInfo -extractRtsInfo lbi = - case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of - [(_, [rts])] -> aux rts - _otherwise -> error "No (or multiple) ghc rts package is registered" - where - aux :: InstalledPackageInfo -> RtsInfo - aux rts = RtsInfo { - rtsDynamicInfo = DynamicRtsInfo { - dynRtsVanillaLib = withGhcVersion "HSrts" - , dynRtsThreadedLib = withGhcVersion "HSrts_thr" - , dynRtsDebugLib = withGhcVersion "HSrts_debug" - , dynRtsEventlogLib = withGhcVersion "HSrts_l" - , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug" - , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l" - } - , rtsStaticInfo = StaticRtsInfo { - statRtsVanillaLib = "HSrts" - , statRtsThreadedLib = "HSrts_thr" - , statRtsDebugLib = "HSrts_debug" - , statRtsEventlogLib = "HSrts_l" - , statRtsThreadedDebugLib = "HSrts_thr_debug" - , statRtsThreadedEventlogLib = "HSrts_thr_l" - , statRtsProfilingLib = "HSrts_p" - , statRtsThreadedProfilingLib = "HSrts_thr_p" - } - , rtsLibPaths = InstalledPackageInfo.libraryDirs rts - } - withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi)))) - --- | Returns True if the modification date of the given source file is newer than --- the object file we last compiled for it, or if no object file exists yet. -checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool -checkNeedsRecompilation filename opts = filename `moreRecentFile` oname - where oname = getObjectFileName filename opts - --- | Finds the object file name of the given source file -getObjectFileName :: FilePath -> GhcOptions -> FilePath -getObjectFileName filename opts = oname - where odir = fromFlag (ghcOptObjDir opts) - oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts) - oname = odir replaceExtension filename oext - --- | Calculate the RPATHs for the component we are building. --- --- Calculates relative RPATHs when 'relocatable' is set. -getRPaths :: LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component we are building - -> IO (NubListR FilePath) -getRPaths lbi clbi | supportRPaths hostOS = do - libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi - let hostPref = case hostOS of - OSX -> "@loader_path" - _ -> "$ORIGIN" - relPath p = if isRelative p then hostPref p else p - rpaths = toNubListR (map relPath libraryPaths) - return rpaths - where - (Platform _ hostOS) = hostPlatform lbi - compid = compilerId . compiler $ lbi - - -- The list of RPath-supported operating systems below reflects the - -- platforms on which Cabal's RPATH handling is tested. It does _NOT_ - -- reflect whether the OS supports RPATH. - - -- E.g. when this comment was written, the *BSD operating systems were - -- untested with regards to Cabal RPATH handling, and were hence set to - -- 'False', while those operating systems themselves do support RPATH. - supportRPaths Linux   = True - supportRPaths Windows = False - supportRPaths OSX   = True - supportRPaths FreeBSD   = - case compid of - CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True - _ -> False - supportRPaths OpenBSD   = False - supportRPaths NetBSD   = False - supportRPaths DragonFly = False - supportRPaths Solaris = False - supportRPaths AIX = False - supportRPaths HPUX = False - supportRPaths IRIX = False - supportRPaths HaLVM = False - supportRPaths IOS = False - supportRPaths Android = False - supportRPaths Ghcjs = False - supportRPaths Hurd = False - supportRPaths (OtherOS _) = False - -- Do _not_ add a default case so that we get a warning here when a new OS - -- is added. - -getRPaths _ _ = return mempty - --- | Remove the "-threaded" flag when building a foreign library, as it has no --- effect when used with "-shared". Returns the updated 'BuildInfo', along --- with whether or not the flag was present, so we can use it to link against --- the appropriate RTS on our own. -popThreadedFlag :: BuildInfo -> (BuildInfo, Bool) -popThreadedFlag bi = - ( bi { options = filterHcOptions (/= "-threaded") (options bi) } - , hasThreaded (options bi)) - - where - filterHcOptions :: (String -> Bool) - -> PerCompilerFlavor [String] - -> PerCompilerFlavor [String] - filterHcOptions p (PerCompilerFlavor ghc ghcjs) = - PerCompilerFlavor (filter p ghc) ghcjs - - hasThreaded :: PerCompilerFlavor [String] -> Bool - hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc - --- | Extracts a String representing a hash of the ABI of a built --- library. It can fail if the library has not yet been built. --- -libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO String -libAbiHash verbosity _pkg_descr lbi lib clbi = do - let - libBi = libBuildInfo lib - comp = compiler lbi - platform = hostPlatform lbi - vanillaArgs0 = - (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi)) - `mappend` mempty { - ghcOptMode = toFlag GhcModeAbiHash, - ghcOptInputModules = toNubListR $ exposedModules lib - } - vanillaArgs = - -- Package DBs unnecessary, and break ghc-cabal. See #3633 - -- BUT, put at least the global database so that 7.4 doesn't - -- break. - vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB] - , ghcOptPackages = mempty } - sharedArgs = vanillaArgs `mappend` mempty { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "js_dyn_hi", - ghcOptObjSuffix = toFlag "js_dyn_o", - ghcOptExtra = hcSharedOptions GHC libBi - } - profArgs = vanillaArgs `mappend` mempty { - ghcOptProfilingMode = toFlag True, - ghcOptProfilingAuto = Internal.profDetailLevelFlag True - (withProfLibDetail lbi), - ghcOptHiSuffix = toFlag "js_p_hi", - ghcOptObjSuffix = toFlag "js_p_o", - ghcOptExtra = hcProfOptions GHC libBi - } - ghcArgs - | withVanillaLib lbi = vanillaArgs - | withSharedLib lbi = sharedArgs - | withProfLib lbi = profArgs - | otherwise = error "libAbiHash: Can't find an enabled library way" - - (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) - hash <- getProgramInvocationOutput verbosity - (ghcInvocation ghcjsProg comp platform ghcArgs) - return (takeWhile (not . isSpace) hash) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir - comp = compiler lbi - implInfo = getImplInfo comp - in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi - } - - -componentCcGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath - -> GhcOptions -componentCcGhcOptions verbosity lbi = - Internal.componentCcGhcOptions verbosity implInfo lbi - where - comp = compiler lbi - implInfo = getImplInfo comp - - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHCJS. -installExe :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi binDir buildPref - (progprefix, progsuffix) _pkg exe = do - createDirectoryIfMissingVerbose verbosity True binDir - let exeName' = unUnqualComponentName $ exeName exe - exeFileName = exeName' - fixedExeBaseName = progprefix ++ exeName' ++ progsuffix - installBinary dest = do - runDbProgram verbosity ghcjsProgram (withPrograms lbi) $ - [ "--install-executable" - , buildPref exeName' exeFileName - , "-o", dest - ] ++ - case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of - (True, Just strip) -> ["-strip-program", programPath strip] - _ -> [] - installBinary (binDir fixedExeBaseName) - - --- |Install foreign library for GHC. -installFLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageDescription - -> ForeignLib - -> IO () -installFLib verbosity lbi targetDir builtDir _pkg flib = - install (foreignLibIsShared flib) - builtDir - targetDir - (flibTargetName lbi flib) - where - install _isShared srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True targetDir - installOrdinaryFile verbosity src dst - - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do - whenVanilla $ copyModuleFiles "js_hi" - whenProf $ copyModuleFiles "js_p_hi" - whenShared $ copyModuleFiles "js_dyn_hi" - - -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName - -- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName - -- whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName - -- fixme do these make the correct lib names? - whenHasCode $ do - whenVanilla $ do - sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f)) - | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib)) - , f <- "":extraLibFlavours (libBuildInfo lib) - ] - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName) - whenProf $ do - installOrdinary builtDir' targetDir (toJSLibName profileLibName) - -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName) - whenShared $ - sequence_ [ installShared builtDir' dynlibTargetDir - (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f)) - | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib) - , f <- "":extraDynLibFlavours (libBuildInfo lib) - ] - where - builtDir' = componentBuildDir lbi clbi - - install isShared isJS srcDir dstDir name = do - let src = srcDir name - dst = dstDir name - createDirectoryIfMissingVerbose verbosity True dstDir - - if isShared - then installExecutableFile verbosity src dst - else installOrdinaryFile verbosity src dst - - when (stripLibs lbi && not isJS) $ - Strip.stripLib verbosity - (hostPlatform lbi) (withPrograms lbi) dst - - installOrdinary = install False True - installShared = install True True - - copyModuleFiles ext = - findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi) - >>= installOrdinaryFiles verbosity targetDir - - compiler_id = compilerId (compiler lbi) - platform = hostPlatform lbi - uid = componentUnitId clbi - -- vanillaLibName = mkLibName uid - profileLibName = mkProfLibName uid - -- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid - - hasLib = not $ null (allLibModules lib clbi) - && null (cSources (libBuildInfo lib)) - && null (cxxSources (libBuildInfo lib)) - && null (jsSources (libBuildInfo lib)) - has_code = not (componentIsIndefinite clbi) - whenHasCode = when has_code - whenVanilla = when (hasLib && withVanillaLib lbi) - whenProf = when (hasLib && withProfLib lbi && has_code) - -- whenGHCi = when (hasLib && withGHCiLib lbi && has_code) - whenShared = when (hasLib && withSharedLib lbi && has_code) - - -adjustExts :: String -> String -> GhcOptions -> GhcOptions -adjustExts hiSuf objSuf opts = - opts `mappend` mempty { - ghcOptHiSuffix = toFlag hiSuf, - ghcOptObjSuffix = toFlag objSuf - } - -isDynamic :: Compiler -> Bool -isDynamic = Internal.ghcLookupProperty "GHC Dynamic" - -supportsDynamicToo :: Compiler -> Bool -supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too" - -withExt :: FilePath -> String -> FilePath -withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else "" - -findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsGhcVersion verbosity pgm = - findProgramVersion "--numeric-ghc-version" id verbosity pgm - -findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version) -findGhcjsPkgGhcjsVersion verbosity pgm = - findProgramVersion "--numeric-ghcjs-version" id verbosity pgm - --- ----------------------------------------------------------------------------- --- Registering - -hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo -hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg - , HcPkg.noPkgDbStack = False - , HcPkg.noVerboseFlag = False - , HcPkg.flagPackageConf = False - , HcPkg.supportsDirDbs = True - , HcPkg.requiresDirDbs = ver >= v7_10 - , HcPkg.nativeMultiInstance = ver >= v7_10 - , HcPkg.recacheMultiInstance = True - , HcPkg.suppressFilesCheck = True - } - where - v7_10 = mkVersion [7,10] - ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb - ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions = - HcPkg.register (hcPkgInfo progdb) verbosity packageDbs - installedPkgInfo registerOptions - -pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath -pkgRoot verbosity lbi = pkgRoot' - where - pkgRoot' GlobalPackageDB = - let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi) - in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg) - pkgRoot' UserPackageDB = do - appDir <- getAppUserDataDirectory "ghcjs" - -- fixme correct this version - let ver = compilerVersion (compiler lbi) - subdir = System.Info.arch ++ '-':System.Info.os - ++ '-':prettyShow ver - rootDir = appDir subdir - -- We must create the root directory for the user package database if it - -- does not yet exists. Otherwise '${pkgroot}' will resolve to a - -- directory at the time of 'ghc-pkg register', and registration will - -- fail. - createDirectoryIfMissing True rootDir - return rootDir - pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp) - - --- | Get the JavaScript file name and command and arguments to run a --- program compiled by GHCJS --- the exe should be the base program name without exe extension -runCmd :: ProgramDb -> FilePath - -> (FilePath, FilePath, [String]) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +module Distribution.Simple.GHCJS + ( getGhcInfo + , configure + , configureCompiler + , compilerProgramDb + , getInstalledPackages + , getInstalledPackagesMonitorFiles + , getPackageDBContents + , buildLib + , buildFLib + , buildExe + , replLib + , replFLib + , replExe + , startInterpreter + , installLib + , installFLib + , installExe + , libAbiHash + , hcPkgInfo + , registerPackage + , componentGhcOptions + , Internal.componentCcGhcOptions + , getLibDir + , isDynamic + , getGlobalPackageDB + , pkgRoot + , runCmd + + -- * Constructing and deconstructing GHC environment files + , Internal.GhcEnvironmentFileEntry (..) + , Internal.simpleGhcEnvironmentFile + , Internal.renderGhcEnvironmentFile + , Internal.writeGhcEnvironmentFile + , Internal.ghcPlatformAndVersionString + , readGhcEnvironmentFile + , parseGhcEnvironmentFile + , ParseErrorExc (..) + + -- * Version-specific implementation quirks + , getImplInfo + , GhcImplInfo (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.CabalSpecVersion +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.PackageDescription.Utils (cabalBug) +import Distribution.Pretty +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.GHC.EnvironmentParser +import Distribution.Simple.GHC.ImplInfo +import qualified Distribution.Simple.GHC.Internal as Internal +import qualified Distribution.Simple.Hpc as Hpc +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex (InstalledPackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Strip as Strip +import Distribution.Simple.Setup.Common +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.PackageName.Magic +import Distribution.Types.ParStrat +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity (Verbosity) +import Distribution.Version + +import Control.Arrow ((***)) +import Control.Monad (msum) +import Data.Char (isLower) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import System.Directory + ( canonicalizePath + , createDirectoryIfMissing + , doesFileExist + , getAppUserDataDirectory + , removeFile + , renameFile + ) +import System.FilePath + ( isRelative + , replaceExtension + , takeDirectory + , takeExtension + ) +import qualified System.Info + +-- ----------------------------------------------------------------------------- +-- Configuring + +-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@ +-- as well as toolchain programs such as @ar@, @ld. +configure + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghcjs@ path (optional) + -> Maybe FilePath + -- ^ user-specified @ghcjs-pkg@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath hcPkgPath conf0 = do + (comp, compPlatform, progdb1) <- configureCompiler verbosity hcPath conf0 + compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath + return (comp, compPlatform, compProgDb) + +-- | Configure GHCJS. +configureCompiler + :: Verbosity + -> Maybe FilePath + -- ^ user-specified @ghc@ path (optional) + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configureCompiler verbosity hcPath conf0 = do + (ghcjsProg, ghcjsVersion, progdb1) <- + requireProgramVersion + verbosity + ghcjsProgram + (orLaterVersion (mkVersion [0, 1])) + (userMaybeSpecifyPath "ghcjs" hcPath conf0) + + Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) + unless (ghcjsGhcVersion < mkVersion [8, 8]) $ + warn verbosity $ + "Unknown/unsupported 'ghc' version detected " + ++ "(Cabal " + ++ prettyShow cabalVersion + ++ " supports 'ghc' version < 8.8): " + ++ programPath ghcjsProg + ++ " is based on GHC version " + ++ prettyShow ghcjsGhcVersion + + let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion + + languages <- Internal.getLanguages verbosity implInfo ghcjsProg + extensions <- Internal.getExtensions verbosity implInfo ghcjsProg + + ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg + let ghcInfoMap = Map.fromList ghcjsInfo + + let comp = + Compiler + { compilerId = CompilerId GHCJS ghcjsVersion + , compilerAbiTag = + AbiTag $ + "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion) + , compilerCompat = [CompilerId GHC ghcjsGhcVersion] + , compilerLanguages = languages + , compilerExtensions = extensions + , compilerProperties = ghcInfoMap + } + compPlatform = Internal.targetPlatform ghcjsInfo + return (comp, compPlatform, progdb1) + +-- | Given a configured @ghcjs@ program, configure auxiliary programs such +-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable. +compilerProgramDb + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe FilePath + -- ^ user-specified @ghc-pkg@ path (optional) + -> IO ProgramDb +compilerProgramDb verbosity comp progdb1 hcPkgPath = do + let + ghcjsProg = fromJust $ lookupProgram ghcjsProgram progdb1 + ghcjsVersion = compilerVersion comp + ghcjsGhcVersion = case compilerCompat comp of + [CompilerId GHC ghcjsGhcVer] -> ghcjsGhcVer + compat -> error $ "could not parse ghcjsGhcVersion:" ++ show compat + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <- + requireProgramVersion + verbosity + ghcjsPkgProgram + { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg + } + anyVersion + (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1) + + Just ghcjsPkgGhcjsVersion <- + findGhcjsPkgGhcjsVersion + verbosity + (programPath ghcjsPkgProg) + + when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ + dieWithException verbosity $ + VersionMismatchJS + (programPath ghcjsProg) + ghcjsVersion + (programPath ghcjsPkgProg) + ghcjsPkgGhcjsVersion + + when (ghcjsGhcVersion /= ghcjsPkgVersion) $ + dieWithException verbosity $ + VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion + + -- Likewise we try to find the matching hsc2hs and haddock programs. + let hsc2hsProgram' = + hsc2hsProgram + { programFindLocation = + guessHsc2hsFromGhcjsPath ghcjsProg + } + haddockProgram' = + haddockProgram + { programFindLocation = + guessHaddockFromGhcjsPath ghcjsProg + } + hpcProgram' = + hpcProgram + { programFindLocation = guessHpcFromGhcjsPath ghcjsProg + } + {- + runghcProgram' = runghcProgram { + programFindLocation = guessRunghcFromGhcjsPath ghcjsProg + } -} + progdb3 = + addKnownProgram haddockProgram' $ + addKnownProgram hsc2hsProgram' $ + addKnownProgram hpcProgram' $ + {- addKnownProgram runghcProgram' -} progdb2 + + return progdb3 + +guessGhcjsPkgFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram + +guessHsc2hsFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram + +guessHaddockFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram + +guessHpcFromGhcjsPath + :: ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram + +guessToolFromGhcjsPath + :: Program + -> ConfiguredProgram + -> Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) +guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath = + do + let toolname = programName tool + given_path = programPath ghcjsProg + given_dir = takeDirectory given_path + real_path <- canonicalizePath given_path + let real_dir = takeDirectory real_path + versionSuffix path = takeVersionSuffix (dropExeExtension path) + given_suf = versionSuffix given_path + real_suf = versionSuffix real_path + guessNormal dir = dir toolname <.> exeExtension buildPlatform + guessGhcjs dir = + dir + (toolname ++ "-ghcjs") + <.> exeExtension buildPlatform + guessGhcjsVersioned dir suf = + dir + (toolname ++ "-ghcjs" ++ suf) + <.> exeExtension buildPlatform + guessVersioned dir suf = + dir + (toolname ++ suf) + <.> exeExtension buildPlatform + mkGuesses dir suf + | null suf = [guessGhcjs dir, guessNormal dir] + | otherwise = + [ guessGhcjsVersioned dir suf + , guessVersioned dir suf + , guessGhcjs dir + , guessNormal dir + ] + guesses = + mkGuesses given_dir given_suf + ++ if real_path == given_path + then [] + else mkGuesses real_dir real_suf + info verbosity $ + "looking for tool " + ++ toolname + ++ " near compiler in " + ++ given_dir + debug verbosity $ "candidate locations: " ++ show guesses + exists <- traverse doesFileExist guesses + case [file | (file, True) <- zip guesses exists] of + -- If we can't find it near ghc, fall back to the usual + -- method. + [] -> programFindLocation tool verbosity searchpath + (fp : _) -> do + info verbosity $ "found " ++ toolname ++ " in " ++ fp + let lookedAt = + map fst + . takeWhile (\(_file, exist) -> not exist) + $ zip guesses exists + return (Just (fp, lookedAt)) + where + takeVersionSuffix :: FilePath -> String + takeVersionSuffix = takeWhileEndLE isSuffixChar + + isSuffixChar :: Char -> Bool + isSuffixChar c = isDigit c || c == '.' || c == '-' + +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)] +getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg + where + version = fromMaybe (error "GHCJS.getGhcInfo: no version") $ programVersion ghcjsProg + implInfo = ghcVersionImplInfo version + +-- | Given a single package DB, return all installed packages. +getPackageDBContents + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getPackageDBContents verbosity mbWorkDir packagedb progdb = do + pkgss <- getInstalledPackages' verbosity mbWorkDir [packagedb] progdb + toPackageIndex verbosity pkgss progdb + +-- | Given a package DB stack, return all installed packages. +getInstalledPackages + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity mbWorkDir packagedbs progdb = do + checkPackageDbEnvVar verbosity + checkPackageDbStack verbosity packagedbs + pkgss <- getInstalledPackages' verbosity mbWorkDir packagedbs progdb + index <- toPackageIndex verbosity pkgss progdb + return $! index + +toPackageIndex + :: Verbosity + -> [(PackageDBX a, [InstalledPackageInfo])] + -> ProgramDb + -> IO InstalledPackageIndex +toPackageIndex verbosity pkgss progdb = do + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it. + topDir <- getLibDir' verbosity ghcjsProg + let indices = + [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss + ] + return $! (mconcat indices) + where + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +getLibDir verbosity lbi = + dropWhileEndLE isSpace + `fmap` getDbProgramOutput + verbosity + ghcjsProgram + (withPrograms lbi) + ["--print-libdir"] + +getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +getLibDir' verbosity ghcjsProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"] + +-- | Return the 'FilePath' to the global GHC package database. +getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath +getGlobalPackageDB verbosity ghcProg = + dropWhileEndLE isSpace + `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"] + +-- | Return the 'FilePath' to the per-user GHC package database. +getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath +getUserPackageDB _verbosity ghcjsProg platform = do + -- It's rather annoying that we have to reconstruct this, because ghc + -- hides this information from us otherwise. But for certain use cases + -- like change monitoring it really can't remain hidden. + appdir <- getAppUserDataDirectory "ghcjs" + return (appdir platformAndVersion packageConfFileName) + where + platformAndVersion = + Internal.ghcPlatformAndVersionString + platform + ghcjsVersion + packageConfFileName = "package.conf.d" + ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg + +checkPackageDbEnvVar :: Verbosity -> IO () +checkPackageDbEnvVar verbosity = + Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH" + +checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO () +checkPackageDbStack _ (GlobalPackageDB : rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack verbosity rest + | GlobalPackageDB `notElem` rest = + dieWithException verbosity GlobalPackageDBLimitation +checkPackageDbStack verbosity _ = + dieWithException verbosity GlobalPackageDBSpecifiedFirst + +getInstalledPackages' + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> [PackageDBX (SymbolicPath from (Dir PkgDB))] + -> ProgramDb + -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])] +getInstalledPackages' verbosity mbWorkDir packagedbs progdb = + sequenceA + [ do + pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity mbWorkDir packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs + ] + +-- | Get the packages from specific PackageDBs, not cumulative. +getInstalledPackagesMonitorFiles + :: Verbosity + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> ProgramDb + -> [PackageDB] + -> IO [FilePath] +getInstalledPackagesMonitorFiles verbosity platform mbWorkDir progdb = + traverse getPackageDBPath + where + getPackageDBPath :: PackageDB -> IO FilePath + getPackageDBPath GlobalPackageDB = + selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg + getPackageDBPath UserPackageDB = + selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform + getPackageDBPath (SpecificPackageDB path) = selectMonitorFile (interpretSymbolicPath mbWorkDir path) + + -- GHC has old style file dbs, and new style directory dbs. + -- Note that for dir style dbs, we only need to monitor the cache file, not + -- the whole directory. The ghc program itself only reads the cache file + -- so it's safe to only monitor this one file. + selectMonitorFile path0 = do + let path = + if isRelative path0 + then interpretSymbolicPath mbWorkDir (makeRelativePathEx path0) + else path0 + isFileStyle <- doesFileExist path + if isFileStyle + then return path + else return (path "package.cache") + + ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb + +toJSLibName :: String -> String +toJSLibName lib + | takeExtension lib `elem` [".dll", ".dylib", ".so"] = + replaceExtension lib "js_so" + | takeExtension lib == ".a" = replaceExtension lib "js_a" + | otherwise = lib <.> "js_a" + +-- ----------------------------------------------------------------------------- +-- Building a library + +buildLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildLib = buildOrReplLib Nothing + +replLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +replLib = buildOrReplLib . Just + +buildOrReplLib + :: Maybe [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () +buildOrReplLib mReplFlags verbosity numJobs _pkg_descr lbi lib clbi = do + let uid = componentUnitId clbi + libTargetDir = componentBuildDir lbi clbi + whenVanillaLib forceVanilla = + when (forceVanilla || withVanillaLib lbi) + whenProfLib = when (withProfLib lbi) + whenSharedLib forceShared = + when (forceShared || withSharedLib lbi) + whenStaticLib forceStatic = + when (forceStatic || withStaticLib lbi) + -- whenGHCiLib = when (withGHCiLib lbi) + forRepl = maybe False (const True) mReplFlags + -- ifReplLib = when forRepl + comp = compiler lbi + implInfo = getImplInfo comp + platform@(Platform _hostArch _hostOS) = hostPlatform lbi + has_code = not (componentIsIndefinite clbi) + mbWorkDir = mbWorkDirLBI lbi + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPathLBI lbi + u :: SymbolicPathX allowAbs Pkg to -> FilePath + u = getSymbolicPath + + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let runGhcjsProg = runGHC verbosity ghcjsProg comp platform mbWorkDir + + let libBi = libBuildInfo lib + + -- fixme flags shouldn't depend on ghcjs being dynamic or not + let isGhcjsDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + doingTH = usesTemplateHaskellOrQQ libBi + forceVanillaLib = doingTH && not isGhcjsDynamic + forceSharedLib = doingTH && isGhcjsDynamic + -- TH always needs default libs, even when building for profiling + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = libCoverage lbi + hpcdir way + | forRepl = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (coerceSymbolicPath libTargetDir coerceSymbolicPath extraCompilationArtifacts) way + | otherwise = mempty + + createDirectoryIfMissingVerbose verbosity True $ i libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? + let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi) + jsSrcs = jsSources libBi + cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cLikeFiles + baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir + linkJsLibOpts = + mempty + { ghcOptExtra = + [ "-link-js-lib" + , getHSLibraryName uid + , "-js-lib-outputdir" + , u libTargetDir + ] + ++ map u jsSrcs + } + vanillaOptsNoJsLib = + baseOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptNumJobs = numJobs + , ghcOptInputModules = toNubListR $ allLibModules lib clbi + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts + + profOpts = + adjustExts "p_hi" "p_o" vanillaOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + True + (withProfLibDetail lbi) + , -- ghcOptHiSuffix = toFlag "p_hi", + -- ghcOptObjSuffix = toFlag "p_o", + ghcOptExtra = hcProfOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Prof + } + + sharedOpts = + adjustExts "dyn_hi" "dyn_o" vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , -- ghcOptHiSuffix = toFlag "dyn_hi", + -- ghcOptObjSuffix = toFlag "dyn_o", + ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + vanillaSharedOpts = + vanillaOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "js_dyn_hi" + , ghcOptDynObjSuffix = toFlag "js_dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + + unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $ + do + let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts) + shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts) + useDynToo = + dynamicTooSupported + && (forceVanillaLib || withVanillaLib lbi) + && (forceSharedLib || withSharedLib lbi) + && null (hcSharedOptions GHC libBi) + if not has_code + then vanilla + else + if useDynToo + then do + runGhcjsProg vanillaSharedOpts + case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of + (Flag dynDir, Flag vanillaDir) -> + -- When the vanilla and shared library builds are done + -- in one pass, only one set of HPC module interfaces + -- are generated. This set should suffice for both + -- static and dynamically linked executables. We copy + -- the modules interfaces so they are available under + -- both ways. + copyDirectoryRecursive verbosity (i dynDir) (i vanillaDir) + _ -> return () + else + if isGhcjsDynamic + then do shared; vanilla + else do vanilla; shared + whenProfLib (runGhcjsProg profOpts) + + -- Build any C++ sources separately. + {- + unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCxxOpts = if isGhcjsDynamic + then baseCxxOpts { ghcOptFPic = toFlag True } + else baseCxxOpts + profCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCxxOpts = vanillaCxxOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCxxOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded cxxOpts = do + needsRecomp <- checkNeedsRecompilation filename cxxOpts + when needsRecomp $ runGhcjsProg cxxOpts + runGhcProgIfNeeded vanillaCxxOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts) + | filename <- cxxSources libBi] + + ifReplLib $ do + when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules" + ifReplLib (runGhcjsProg replOpts) + -} + -- build any C sources + -- TODO: Add support for S and CMM files. + {- + unless (not has_code || null (cSources libBi) || not nativeToo) $ do + info verbosity "Building C Sources..." + sequence_ + [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo + lbi libBi clbi libTargetDir filename + vanillaCcOpts = if isGhcjsDynamic + -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + then baseCcOpts { ghcOptFPic = toFlag True } + else baseCcOpts + profCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptProfilingMode = toFlag True, + ghcOptObjSuffix = toFlag "p_o" + } + sharedCcOpts = vanillaCcOpts `mappend` mempty { + ghcOptFPic = toFlag True, + ghcOptDynLinkMode = toFlag GhcDynamicOnly, + ghcOptObjSuffix = toFlag "dyn_o" + } + odir = fromFlag (ghcOptObjDir vanillaCcOpts) + createDirectoryIfMissingVerbose verbosity True odir + let runGhcProgIfNeeded ccOpts = do + needsRecomp <- checkNeedsRecompilation filename ccOpts + when needsRecomp $ runGhcjsProg ccOpts + runGhcProgIfNeeded vanillaCcOpts + unless forRepl $ + whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts) + unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts) + | filename <- cSources libBi] + -} + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + + -- link: + + when has_code . when False {- fixme nativeToo -} . unless forRepl $ do + info verbosity "Linking..." + let cSharedObjs = + map + ((`replaceExtensionSymbolicPath` ("dyn_" ++ objExtension))) + (cSources libBi ++ cxxSources libBi) + compiler_id = compilerId (compiler lbi) + sharedLibFilePath = libTargetDir makeRelativePathEx (mkSharedLibName (hostPlatform lbi) compiler_id uid) + staticLibFilePath = libTargetDir makeRelativePathEx (mkStaticLibName (hostPlatform lbi) compiler_id uid) + + let stubObjs = [] + stubSharedObjs = [] + + {- + stubObjs <- catMaybes <$> sequenceA + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubProfObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + stubSharedObjs <- catMaybes <$> sequenceA + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files + , x <- allLibModules lib clbi ] + -} + hObjs <- + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + (coerceSymbolicPath libTargetDir) + objExtension + True + hSharedObjs <- + if withSharedLib lbi + then + Internal.getHaskellObjects + implInfo + lib + lbi + clbi + (coerceSymbolicPath libTargetDir) + ("dyn_" ++ objExtension) + False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + rpaths <- getRPaths lbi clbi + + let staticObjectFiles = + hObjs + ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (makeSymbolicPath . (getSymbolicPath libTargetDir ) . getSymbolicPath) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + mempty + { ghcOptShared = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptInputFiles = toNubListR dynamicObjectFiles + , ghcOptOutputFile = toFlag sharedLibFilePath + , ghcOptExtra = hcOptions GHC libBi ++ hcSharedOptions GHC libBi + , -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. This only applies to GHC < 7.8 - see the + -- discussion in #1660. + {- + ghcOptDylibName = if hostOS == OSX + && ghcVersion < mkVersion [7,8] + then toFlag sharedLibInstallPath + else mempty, -} + ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + , ghcOptLinkFrameworks = toNubListR $ map getSymbolicPath $ PD.frameworks libBi + , ghcOptLinkFrameworkDirs = + toNubListR $ PD.extraFrameworkDirs libBi + , ghcOptRPaths = rpaths + } + ghcStaticLinkArgs = + mempty + { ghcOptStaticLib = toFlag True + , ghcOptInputFiles = toNubListR staticObjectFiles + , ghcOptOutputFile = toFlag staticLibFilePath + , ghcOptExtra = hcStaticOptions GHC libBi + , ghcOptHideAllPackages = toFlag True + , ghcOptNoAutoLinkPackages = toFlag True + , ghcOptPackageDBs = withPackageDB lbi + , ghcOptThisUnitId = case clbi of + LibComponentLocalBuildInfo{componentCompatPackageKey = pk} -> + toFlag pk + _ -> mempty + , ghcOptThisComponentId = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + if null insts + then mempty + else toFlag (componentComponentId clbi) + _ -> mempty + , ghcOptInstantiatedWith = case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> + insts + _ -> [] + , ghcOptPackages = + toNubListR $ + Internal.mkGhcOptPackages mempty clbi + , ghcOptLinkLibs = extraLibs libBi + , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi + } + + info verbosity (show (ghcOptPackages ghcSharedLinkArgs)) + {- + whenVanillaLib False $ do + Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciLibFilePath staticObjectFiles + -} + {- + whenProfLib $ do + Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles + whenGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity lbi ldProg + ghciProfLibFilePath profObjectFiles + -} + whenSharedLib False $ + runGhcjsProg ghcSharedLinkArgs + + whenStaticLib False $ + runGhcjsProg ghcStaticLinkArgs + +-- | Start a REPL without loading any source files. +startInterpreter + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> PackageDBStack + -> IO () +startInterpreter verbosity progdb comp platform packageDBs = do + let replOpts = + mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptPackageDBs = packageDBs + } + checkPackageDbStack verbosity packageDBs + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb + runGHC verbosity ghcjsProg comp platform Nothing replOpts + +-- ----------------------------------------------------------------------------- +-- Building an executable or foreign library + +-- | Build a foreign library +buildFLib + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib + +replFLib + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> ForeignLib + -> ComponentLocalBuildInfo + -> IO () +replFLib replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplFLib replFlags + +-- | Build an executable with GHC. +buildExe + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe + +replExe + :: [String] + -> Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () +replExe replFlags v njobs pkg lbi = + gbuild v njobs pkg lbi . GReplExe replFlags + +-- | Building an executable, starting the REPL, and building foreign +-- libraries are all very similar and implemented in 'gbuild'. The +-- 'GBuildMode' distinguishes between the various kinds of operation. +data GBuildMode + = GBuildExe Executable + | GReplExe [String] Executable + | GBuildFLib ForeignLib + | GReplFLib [String] ForeignLib + +gbuildInfo :: GBuildMode -> BuildInfo +gbuildInfo (GBuildExe exe) = buildInfo exe +gbuildInfo (GReplExe _ exe) = buildInfo exe +gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib +gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib + +gbuildName :: GBuildMode -> String +gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe +gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe +gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib +gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib + +gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String +gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe +gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib +gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib + +exeTargetName :: Platform -> Executable -> String +exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform + +-- | Target name for a foreign library (the actual file name) +-- +-- We do not use mkLibName and co here because the naming for foreign libraries +-- is slightly different (we don't use "_p" or compiler version suffices, and we +-- don't want the "lib" prefix on Windows). +-- +-- TODO: We do use `dllExtension` and co here, but really that's wrong: they +-- use the OS used to build cabal to determine which extension to use, rather +-- than the target OS (but this is wrong elsewhere in Cabal as well). +flibTargetName :: LocalBuildInfo -> ForeignLib -> String +flibTargetName lbi flib = + case (os, foreignLibType flib) of + (Windows, ForeignLibNativeShared) -> nm <.> "dll" + (Windows, ForeignLibNativeStatic) -> nm <.> "lib" + (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt + (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi) + (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi) + (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type" + where + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + -- If a foreign lib foo has lib-version-info 5:1:2 or + -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1 + -- Libtool's version-info data is translated into library versions in a + -- nontrivial way: so refer to libtool documentation. + versionedExt :: String + versionedExt = + let nums = foreignLibVersion flib os + in foldl (<.>) "so" (map show nums) + +-- | Name for the library when building. +-- +-- If the `lib-version-info` field or the `lib-version-linux` field of +-- a foreign library target is set, we need to incorporate that +-- version into the SONAME field. +-- +-- If a foreign library foo has lib-version-info 5:1:2, it should be +-- built as libfoo.so.3.2.1. We want it to get soname libfoo.so.3. +-- However, GHC does not allow overriding soname by setting linker +-- options, as it sets a soname of its own (namely the output +-- filename), after the user-supplied linker options. Hence, we have +-- to compile the library with the soname as its filename. We rename +-- the compiled binary afterwards. +-- +-- This method allows to adjust the name of the library at build time +-- such that the correct soname can be set. +flibBuildName :: LocalBuildInfo -> ForeignLib -> String +flibBuildName lbi flib + -- On linux, if a foreign-library has version data, the first digit is used + -- to produce the SONAME. + | (os, foreignLibType flib) + == (Linux, ForeignLibNativeShared) = + let nums = foreignLibVersion flib os + in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums)) + | otherwise = flibTargetName lbi flib + where + os :: OS + os = + let (Platform _ os') = hostPlatform lbi + in os' + + nm :: String + nm = unUnqualComponentName $ foreignLibName flib + +gbuildIsRepl :: GBuildMode -> Bool +gbuildIsRepl (GBuildExe _) = False +gbuildIsRepl (GReplExe _ _) = True +gbuildIsRepl (GBuildFLib _) = False +gbuildIsRepl (GReplFLib _ _) = True + +gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool +gbuildNeedDynamic lbi bm = + case bm of + GBuildExe _ -> withDynExe lbi + GReplExe _ _ -> withDynExe lbi + GBuildFLib flib -> withDynFLib flib + GReplFLib _ flib -> withDynFLib flib + where + withDynFLib flib = + case foreignLibType flib of + ForeignLibNativeShared -> + ForeignLibStandalone `notElem` foreignLibOptions flib + ForeignLibNativeStatic -> + False + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + +gbuildModDefFiles :: GBuildMode -> [RelativePath Source File] +gbuildModDefFiles (GBuildExe _) = [] +gbuildModDefFiles (GReplExe _ _) = [] +gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib +gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib + +-- | "Main" module name when overridden by @ghc-options: -main-is ...@ +-- or 'Nothing' if no @-main-is@ flag could be found. +-- +-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed. +exeMainModuleName :: Executable -> Maybe ModuleName +exeMainModuleName Executable{buildInfo = bnfo} = + -- GHC honors the last occurrence of a module name updated via -main-is + -- + -- Moreover, -main-is when parsed left-to-right can update either + -- the "Main" module name, or the "main" function name, or both, + -- see also 'decodeMainIsArg'. + msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts + where + ghcopts = hcOptions GHC bnfo + + findIsMainArgs [] = [] + findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest + findIsMainArgs (_ : rest) = findIsMainArgs rest + +-- | Decode argument to '-main-is' +-- +-- Returns 'Nothing' if argument set only the function name. +-- +-- This code has been stolen/refactored from GHC's DynFlags.setMainIs +-- function. The logic here is deliberately imperfect as it is +-- intended to be bug-compatible with GHC's parser. See discussion in +-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753. +decodeMainIsArg :: String -> Maybe ModuleName +decodeMainIsArg arg + | headOf main_fn isLower = + -- The arg looked like "Foo.Bar.baz" + Just (ModuleName.fromString main_mod) + | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar" + = + Just (ModuleName.fromString arg) + | otherwise -- The arg looked like "baz" + = + Nothing + where + headOf :: String -> (Char -> Bool) -> Bool + headOf str pred' = any pred' (safeHead str) + + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + + splitLongestPrefix :: String -> (Char -> Bool) -> (String, String) + splitLongestPrefix str pred' + | null r_pre = (str, []) + | otherwise = (reverse (safeTail r_pre), reverse r_suf) + where + -- 'safeTail' drops the char satisfying 'pred' + (r_suf, r_pre) = break pred' (reverse str) + +-- | A collection of: +-- * C input files +-- * C++ input files +-- * GHC input files +-- * GHC input modules +-- +-- Used to correctly build and link sources. +data BuildSources = BuildSources + { cSourcesFiles :: [SymbolicPath Pkg File] + , cxxSourceFiles :: [SymbolicPath Pkg File] + , inputSourceFiles :: [SymbolicPath Pkg File] + , inputSourceModules :: [ModuleName] + } + +-- | Locate and return the 'BuildSources' required to build and link. +gbuildSources + :: Verbosity + -> Maybe (SymbolicPath CWD ('Dir Pkg)) + -> PackageId + -> CabalSpecVersion + -> SymbolicPath Pkg (Dir Source) + -> GBuildMode + -> IO BuildSources +gbuildSources verbosity mbWorkDir pkgId specVer tmpDir bm = + case bm of + GBuildExe exe -> exeSources exe + GReplExe _ exe -> exeSources exe + GBuildFLib flib -> return $ flibSources flib + GReplFLib _ flib -> return $ flibSources flib + where + exeSources :: Executable -> IO BuildSources + exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do + main <- findFileCwd verbosity mbWorkDir (tmpDir : hsSourceDirs bnfo) modPath + let mainModName = fromMaybe ModuleName.main $ exeMainModuleName exe + otherModNames = exeModules exe + haskellMain = isHaskell (getSymbolicPath main) + + -- Scripts have fakePackageId and are always Haskell but can have any extension. + if haskellMain || pkgId == fakePackageId + then + if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames) + then do + -- The cabal manual clearly states that `other-modules` is + -- intended for non-main modules. However, there's at least one + -- important package on Hackage (happy-1.19.5) which + -- violates this. We workaround this here so that we don't + -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which + -- would result in GHC complaining about duplicate Main + -- modules. + -- + -- Finally, we only enable this workaround for + -- specVersion < 2, as 'cabal-version:>=2.0' cabal files + -- have no excuse anymore to keep doing it wrong... ;-) + warn verbosity $ + "Enabling workaround for Main module '" + ++ prettyShow mainModName + ++ "' listed in 'other-modules' illegally!" + + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = filter (/= mainModName) $ exeModules exe + } + else + return + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [main] + , inputSourceModules = exeModules exe + } + else + let (csf, cxxsf) + | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo) + -- if main is not a Haskell source + -- and main is not a C++ source + -- then we assume that it is a C source + | otherwise = (main : cSources bnfo, cxxSources bnfo) + in return + BuildSources + { cSourcesFiles = csf + , cxxSourceFiles = cxxsf + , inputSourceFiles = [] + , inputSourceModules = exeModules exe + } + + flibSources :: ForeignLib -> BuildSources + flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} = + BuildSources + { cSourcesFiles = cSources bnfo + , cxxSourceFiles = cxxSources bnfo + , inputSourceFiles = [] + , inputSourceModules = foreignLibModules flib + } + + isCxx :: FilePath -> Bool + isCxx fp = elem (takeExtension fp) [".cpp", ".cxx", ".c++"] + +-- | FilePath has a Haskell extension: .hs or .lhs +isHaskell :: FilePath -> Bool +isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"] + +-- | Generic build function. See comment for 'GBuildMode'. +gbuild + :: Verbosity + -> Flag ParStrat + -> PackageDescription + -> LocalBuildInfo + -> GBuildMode + -> ComponentLocalBuildInfo + -> IO () +gbuild verbosity numJobs pkg_descr lbi bm clbi = do + (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) + let replFlags = case bm of + GReplExe flags _ -> flags + GReplFLib flags _ -> flags + GBuildExe{} -> mempty + GBuildFLib{} -> mempty + comp = compiler lbi + platform = hostPlatform lbi + mbWorkDir = mbWorkDirLBI lbi + runGhcProg = runGHC verbosity ghcjsProg comp platform mbWorkDir + + let (bnfo, threaded) = case bm of + GBuildFLib _ -> popThreadedFlag (gbuildInfo bm) + _ -> (gbuildInfo bm, False) + + -- the name that GHC really uses (e.g., with .exe on Windows for executables) + let targetName = gbuildTargetName lbi bm + targetDir = buildDir lbi makeRelativePathEx (gbuildName bm) + tmpDir = targetDir makeRelativePathEx (gbuildName bm ++ "-tmp") + + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + + createDirectoryIfMissingVerbose verbosity True $ i targetDir + createDirectoryIfMissingVerbose verbosity True $ i tmpDir + + -- TODO: do we need to put hs-boot files into place for mutually recursive + -- modules? FIX: what about exeName.hi-boot? + + -- Determine if program coverage should be enabled and if so, what + -- '-hpcdir' should be. + let isCoverageEnabled = exeCoverage lbi + hpcdir way + | gbuildIsRepl bm = mempty -- HPC is not supported in ghci + | isCoverageEnabled = toFlag $ Hpc.mixDir (tmpDir coerceSymbolicPath extraCompilationArtifacts) way + | otherwise = mempty + + rpaths <- getRPaths lbi clbi + buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm + + let cSrcs = cSourcesFiles buildSources + cxxSrcs = cxxSourceFiles buildSources + inputFiles = inputSourceFiles buildSources + inputModules = inputSourceModules buildSources + isGhcDynamic = isDynamic comp + dynamicTooSupported = supportsDynamicToo comp + cObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cSrcs + cxxObjs = map ((`replaceExtensionSymbolicPath` objExtension)) cxxSrcs + needDynamic = gbuildNeedDynamic lbi bm + needProfiling = withProfExe lbi + + -- build executables + buildRunner = case clbi of + LibComponentLocalBuildInfo{} -> False + FLibComponentLocalBuildInfo{} -> False + ExeComponentLocalBuildInfo{} -> True + TestComponentLocalBuildInfo{} -> True + BenchComponentLocalBuildInfo{} -> True + baseOpts = + (componentGhcOptions verbosity lbi bnfo clbi tmpDir) + `mappend` mempty + { ghcOptMode = toFlag GhcModeMake + , ghcOptInputFiles = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (isHaskell . getSymbolicPath) inputFiles + else inputFiles + , ghcOptInputScripts = + toNubListR $ + if package pkg_descr == fakePackageId + then filter (not . isHaskell . getSymbolicPath) inputFiles + else [] + , ghcOptInputModules = toNubListR inputModules + , -- for all executable components (exe/test/bench), + -- GHCJS must be passed the "-build-runner" option + ghcOptExtra = + if buildRunner + then ["-build-runner"] + else mempty + } + staticOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticOnly + , ghcOptHPCDir = hpcdir Hpc.Vanilla + } + profOpts = + baseOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + , ghcOptProfilingAuto = + Internal.profDetailLevelFlag + False + (withProfExeDetail lbi) + , ghcOptHiSuffix = toFlag "p_hi" + , ghcOptObjSuffix = toFlag "p_o" + , ghcOptExtra = hcProfOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Prof + } + dynOpts = + baseOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , -- TODO: Does it hurt to set -fPIC for executables? + ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + dynTooOpts = + staticOpts + `mappend` mempty + { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic + , ghcOptDynHiSuffix = toFlag "dyn_hi" + , ghcOptDynObjSuffix = toFlag "dyn_o" + , ghcOptHPCDir = hpcdir Hpc.Dyn + } + linkerOpts = + mempty + { ghcOptLinkOptions = PD.ldOptions bnfo + , ghcOptLinkLibs = extraLibs bnfo + , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo + , ghcOptLinkFrameworks = + toNubListR $ + map getSymbolicPath $ + PD.frameworks bnfo + , ghcOptLinkFrameworkDirs = + toNubListR $ + PD.extraFrameworkDirs bnfo + , ghcOptInputFiles = + toNubListR + [makeSymbolicPath $ getSymbolicPath tmpDir getSymbolicPath x | x <- cObjs ++ cxxObjs] + } + dynLinkerOpts = + mempty + { ghcOptRPaths = rpaths + } + replOpts = + baseOpts + { ghcOptExtra = + Internal.filterGhciFlags + (ghcOptExtra baseOpts) + <> replFlags + } + -- For a normal compile we do separate invocations of ghc for + -- compiling as for linking. But for repl we have to do just + -- the one invocation, so that one has to include all the + -- linker stuff too, like -l flags and any .o files from C + -- files etc. + `mappend` linkerOpts + `mappend` mempty + { ghcOptMode = toFlag GhcModeInteractive + , ghcOptOptimisation = toFlag GhcNoOptimisation + } + commonOpts + | needProfiling = profOpts + | needDynamic = dynOpts + | otherwise = staticOpts + compileOpts + | useDynToo = dynTooOpts + | otherwise = commonOpts + withStaticExe = not needProfiling && not needDynamic + + -- For building exe's that use TH with -prof or -dynamic we actually have + -- to build twice, once without -prof/-dynamic and then again with + -- -prof/-dynamic. This is because the code that TH needs to run at + -- compile time needs to be the vanilla ABI so it can be loaded up and run + -- by the compiler. + -- With dynamic-by-default GHC the TH object files loaded at compile-time + -- need to be .dyn_o instead of .o. + doingTH = usesTemplateHaskellOrQQ bnfo + -- Should we use -dynamic-too instead of compiling twice? + useDynToo = + dynamicTooSupported + && isGhcDynamic + && doingTH + && withStaticExe + && null (hcSharedOptions GHC bnfo) + compileTHOpts + | isGhcDynamic = dynOpts + | otherwise = staticOpts + compileForTH + | gbuildIsRepl bm = False + | useDynToo = False + | isGhcDynamic = doingTH && (needProfiling || withStaticExe) + | otherwise = doingTH && (needProfiling || needDynamic) + + -- Build static/dynamic object files for TH, if needed. + when compileForTH $ + runGhcProg + compileTHOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- Do not try to build anything if there are no input files. + -- This can happen if the cabal file ends up with only cSrcs + -- but no Haskell modules. + unless + ( (null inputFiles && null inputModules) + || gbuildIsRepl bm + ) + $ runGhcProg + compileOpts + { ghcOptNoLink = toFlag True + , ghcOptNumJobs = numJobs + } + + -- build any C++ sources + unless (null cxxSrcs) $ do + info verbosity "Building C++ Sources..." + sequence_ + [ do + let baseCxxOpts = + Internal.componentCxxGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCxxOpts = + if isGhcDynamic + then -- Dynamic GHC requires C++ sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCxxOpts{ghcOptFPic = toFlag True} + else baseCxxOpts + profCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCxxOpts = + vanillaCxxOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCxxOpts + | needDynamic = sharedCxxOpts + | otherwise = vanillaCxxOpts + -- TODO: Placing all Haskell, C, & C++ objects in a single directory + -- Has the potential for file collisions. In general we would + -- consider this a user error. However, we should strive to + -- add a warning if this occurs. + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True (i odir) + needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cxxSrcs + ] + + -- build any C sources + unless (null cSrcs) $ do + info verbosity "Building C Sources..." + sequence_ + [ do + let baseCcOpts = + Internal.componentCcGhcOptions + verbosity + lbi + bnfo + clbi + tmpDir + filename + vanillaCcOpts = + if isGhcDynamic + then -- Dynamic GHC requires C sources to be built + -- with -fPIC for REPL to work. See #2207. + baseCcOpts{ghcOptFPic = toFlag True} + else baseCcOpts + profCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptProfilingMode = toFlag True + } + sharedCcOpts = + vanillaCcOpts + `mappend` mempty + { ghcOptFPic = toFlag True + , ghcOptDynLinkMode = toFlag GhcDynamicOnly + } + opts + | needProfiling = profCcOpts + | needDynamic = sharedCcOpts + | otherwise = vanillaCcOpts + odir = fromFlag (ghcOptObjDir opts) + createDirectoryIfMissingVerbose verbosity True (i odir) + needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts + when needsRecomp $ + runGhcProg opts + | filename <- cSrcs + ] + + -- TODO: problem here is we need the .c files built first, so we can load them + -- with ghci, but .c files can depend on .h files generated by ghc by ffi + -- exports. + case bm of + GReplExe _ _ -> runGhcProg replOpts + GReplFLib _ _ -> runGhcProg replOpts + GBuildExe _ -> do + let linkOpts = + commonOpts + `mappend` linkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag (null inputFiles) + } + `mappend` (if withDynExe lbi then dynLinkerOpts else mempty) + + info verbosity "Linking..." + -- Work around old GHCs not relinking in this + -- situation, see #3294 + let target = targetDir makeRelativePathEx targetName + when (compilerVersion comp < mkVersion [7, 7]) $ do + let targetPath = i target + e <- doesFileExist targetPath + when e (removeFile targetPath) + runGhcProg linkOpts{ghcOptOutputFile = toFlag target} + GBuildFLib flib -> do + let rtsInfo = extractRtsInfo lbi + rtsOptLinkLibs = + [ if needDynamic + then + if threaded + then dynRtsThreadedLib (rtsDynamicInfo rtsInfo) + else dynRtsVanillaLib (rtsDynamicInfo rtsInfo) + else + if threaded + then statRtsThreadedLib (rtsStaticInfo rtsInfo) + else statRtsVanillaLib (rtsStaticInfo rtsInfo) + ] + linkOpts = case foreignLibType flib of + ForeignLibNativeShared -> + commonOpts + `mappend` linkerOpts + `mappend` dynLinkerOpts + `mappend` mempty + { ghcOptLinkNoHsMain = toFlag True + , ghcOptShared = toFlag True + , ghcOptLinkLibs = rtsOptLinkLibs + , ghcOptLinkLibPath = toNubListR $ map makeSymbolicPath $ rtsLibPaths rtsInfo + , ghcOptFPic = toFlag True + , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm + } + ForeignLibNativeStatic -> + -- this should be caught by buildFLib + -- (and if we do implement this, we probably don't even want to call + -- ghc here, but rather Ar.createArLibArchive or something) + cabalBug "static libraries not yet implemented" + ForeignLibTypeUnknown -> + cabalBug "unknown foreign lib type" + -- We build under a (potentially) different filename to set a + -- soname on supported platforms. See also the note for + -- @flibBuildName@. + info verbosity "Linking..." + let buildName = flibBuildName lbi flib + buildFile = targetDir makeRelativePathEx buildName + runGhcProg linkOpts{ghcOptOutputFile = toFlag buildFile} + renameFile (i buildFile) (i targetDir targetName) + +data DynamicRtsInfo = DynamicRtsInfo + { dynRtsVanillaLib :: FilePath + , dynRtsThreadedLib :: FilePath + , dynRtsDebugLib :: FilePath + , dynRtsEventlogLib :: FilePath + , dynRtsThreadedDebugLib :: FilePath + , dynRtsThreadedEventlogLib :: FilePath + } + +data StaticRtsInfo = StaticRtsInfo + { statRtsVanillaLib :: FilePath + , statRtsThreadedLib :: FilePath + , statRtsDebugLib :: FilePath + , statRtsEventlogLib :: FilePath + , statRtsThreadedDebugLib :: FilePath + , statRtsThreadedEventlogLib :: FilePath + , statRtsProfilingLib :: FilePath + , statRtsThreadedProfilingLib :: FilePath + } + +data RtsInfo = RtsInfo + { rtsDynamicInfo :: DynamicRtsInfo + , rtsStaticInfo :: StaticRtsInfo + , rtsLibPaths :: [FilePath] + } + +-- | Extract (and compute) information about the RTS library +-- +-- TODO: This hardcodes the name as @HSrts-ghc@. 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 diff --git a/src/Distribution/Simple/Glob.hs b/src/Distribution/Simple/Glob.hs --- a/src/Distribution/Simple/Glob.hs +++ b/src/Distribution/Simple/Glob.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Glob -- Copyright : Isaac Jones, Simon Marlow 2003-2004 @@ -13,246 +15,333 @@ -- Portability : portable -- -- Simple file globbing. +module Distribution.Simple.Glob + ( -- * Globs + Glob -module Distribution.Simple.Glob ( - GlobSyntaxError(..), - GlobResult(..), - matchDirFileGlob, - matchDirFileGlobWithDie, - runDirFileGlob, - fileGlobMatches, - parseFileGlob, - explainGlobSyntaxError, - Glob, - ) where + -- * Matching on globs + , GlobResult (..) + , globMatches + , fileGlobMatches + , matchGlob + , matchGlobPieces + , matchDirFileGlob + , matchDirFileGlobWithDie + , runDirFileGlob -import Prelude () + -- * Parsing globs + , parseFileGlob + , GlobSyntaxError (..) + , explainGlobSyntaxError + + -- * Utility + , isRecursiveInRoot + ) +where + import Distribution.Compat.Prelude +import Prelude () import Distribution.CabalSpecVersion + ( CabalSpecVersion (..) + ) +import Distribution.Pretty +import Distribution.Simple.Errors + ( CabalException (MatchDirFileGlob, MatchDirFileGlobErrors) + ) +import Distribution.Simple.Glob.Internal import Distribution.Simple.Utils + ( debug + , dieWithException + , getDirectoryContentsRecursive + , warn + ) +import Distribution.Utils.Path import Distribution.Verbosity + ( Verbosity + , silent + ) -import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist) -import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (), (<.>)) +import Control.Monad (mapM) +import Data.List (stripPrefix) +import System.Directory +import System.FilePath hiding ((<.>), ()) -import qualified Data.List.NonEmpty as NE +------------------------------------------------------------------------------- --- Note throughout that we use splitDirectories, not splitPath. On --- Posix, this makes no difference, but, because Windows accepts both --- slash and backslash as its path separators, if we left in the --- separators from the glob we might not end up properly normalised. +-- * Matching -data GlobResult a - = GlobMatch a - -- ^ The glob matched the value supplied. - | GlobWarnMultiDot a - -- ^ The glob did not match the value supplied because the - -- cabal-version is too low and the extensions on the file did - -- not precisely match the glob's extensions, but rather the - -- glob was a proper suffix of the file's extensions; i.e., if - -- not for the low cabal-version, it would have matched. - | GlobMissingDirectory FilePath - -- ^ The glob couldn't match because the directory named doesn't - -- exist. The directory will be as it appears in the glob (i.e., - -- relative to the directory passed to 'matchDirFileGlob', and, - -- for 'data-files', relative to 'data-dir'). - deriving (Show, Eq, Ord, Functor) +-------------------------------------------------------------------------------- +-- | Match a 'Glob' against the file system, starting from a +-- given root directory. The results are all relative to the given root. +-- +-- @since 3.12.0.0 +matchGlob :: FilePath -> Glob -> IO [FilePath] +matchGlob root glob = + -- For this function, which is the general globbing one (doesn't care about + -- cabal spec, used e.g. for monitoring), we consider all matches. + mapMaybe + ( \case + GlobMatch a -> Just a + GlobWarnMultiDot a -> Just a + GlobMatchesDirectory a -> Just a + GlobMissingDirectory{} -> Nothing + ) + <$> runDirFileGlob silent Nothing root glob + +-- | Match a globbing pattern against a file path component +matchGlobPieces :: GlobPieces -> String -> Bool +matchGlobPieces = goStart + where + -- From the man page, glob(7): + -- "If a filename starts with a '.', this character must be + -- matched explicitly." + + go, goStart :: [GlobPiece] -> String -> Bool + + goStart (WildCard : _) ('.' : _) = False + goStart (Union globs : rest) cs = + any + (\glob -> goStart (glob ++ rest) cs) + globs + goStart rest cs = go rest cs + + go [] "" = True + go (Literal lit : rest) cs + | Just cs' <- stripPrefix lit cs = + go rest cs' + | otherwise = False + go [WildCard] "" = True + go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs + go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs + go [] (_ : _) = False + go (_ : _) "" = False + -- | Extract the matches from a list of 'GlobResult's. -- -- Note: throws away the 'GlobMissingDirectory' results; chances are -- that you want to check for these and error out if any are present. +-- +-- @since 3.12.0.0 globMatches :: [GlobResult a] -> [a] -globMatches input = [ a | GlobMatch a <- input ] - -data GlobSyntaxError - = StarInDirectory - | StarInFileName - | StarInExtension - | NoExtensionOnStar - | EmptyGlob - | LiteralFileNameGlobStar - | VersionDoesNotSupportGlobStar - | VersionDoesNotSupportGlob - deriving (Eq, Show) +globMatches input = [a | GlobMatch a <- input] -explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String -explainGlobSyntaxError filepath StarInDirectory = - "invalid file glob '" ++ filepath - ++ "'. A wildcard '**' is only allowed as the final parent" - ++ " directory. Stars must not otherwise appear in the parent" - ++ " directories." -explainGlobSyntaxError filepath StarInExtension = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed as the" - ++ " file's base name, not in the file extension." -explainGlobSyntaxError filepath StarInFileName = - "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' may only totally replace the" - ++ " file's base name, not only parts of it." -explainGlobSyntaxError filepath NoExtensionOnStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '*' is used it must be with an file extension." -explainGlobSyntaxError filepath LiteralFileNameGlobStar = - "invalid file glob '" ++ filepath - ++ "'. If a wildcard '**' is used as a parent directory, the" - ++ " file's base name must be a wildcard '*'." -explainGlobSyntaxError _ EmptyGlob = - "invalid file glob. A glob cannot be the empty string." -explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = - "invalid file glob '" ++ filepath - ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" - ++ " or greater. Alternatively, for compatibility with earlier Cabal" - ++ " versions, list the included directories explicitly." -explainGlobSyntaxError filepath VersionDoesNotSupportGlob = - "invalid file glob '" ++ filepath - ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " - ++ "Alternatively if you require compatibility with earlier Cabal " - ++ "versions then list all the files explicitly." +-- | This will 'die'' when the glob matches no files, or if the glob +-- refers to a missing directory, or if the glob fails to parse. +-- +-- The 'Version' argument must be the spec version of the package +-- description being processed, as globs behave slightly differently +-- in different spec versions. +-- +-- The first 'FilePath' argument is the directory that the glob is +-- relative to. It must be a valid directory (and hence it can't be +-- the empty string). The returned values will not include this +-- prefix. +-- +-- The second 'FilePath' is the glob itself. +matchDirFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlob v = matchDirFileGlobWithDie v dieWithException -data IsRecursive = Recursive | NonRecursive +-- | Like 'matchDirFileGlob' but with customizable 'die' +-- +-- @since 3.6.0.0 +matchDirFileGlobWithDie + :: Verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir dir)) + -> SymbolicPathX allowAbs dir file + -> IO [SymbolicPathX allowAbs dir file] +matchDirFileGlobWithDie verbosity rip version mbWorkDir symPath = + let rawFilePath = getSymbolicPath symPath + dir = maybe "." getSymbolicPath mbWorkDir + in case parseFileGlob version rawFilePath of + Left err -> rip verbosity $ MatchDirFileGlob (explainGlobSyntaxError rawFilePath err) + Right glob -> do + results <- runDirFileGlob verbosity (Just version) dir glob + let missingDirectories = + [missingDir | GlobMissingDirectory missingDir <- results] + matches = globMatches results + directoryMatches = [a | GlobMatchesDirectory a <- results] -data MultiDot = MultiDotDisabled | MultiDotEnabled + let errors :: [String] + errors = + [ "filepath wildcard '" + ++ rawFilePath + ++ "' refers to the directory" + ++ " '" + ++ missingDir + ++ "', which does not exist or is not a directory." + | missingDir <- missingDirectories + ] + ++ [ "filepath wildcard '" ++ rawFilePath ++ "' does not match any files." + | null matches && null directoryMatches + -- we don't error out on directory matches, simply warn about them and ignore. + ] -data Glob - = GlobStem FilePath Glob - -- ^ A single subdirectory component + remainder. - | GlobFinal GlobFinal + warns :: [String] + warns = + [ "Ignoring directory '" ++ path ++ "'" ++ " listed in a Cabal package field which should only include files (not directories)." + | path <- directoryMatches + ] -data GlobFinal - = FinalMatch IsRecursive MultiDot String - -- ^ First argument: Is this a @**/*.ext@ pattern? - -- Second argument: should we match against the exact extensions, or accept a suffix? - -- Third argument: the extensions to accept. - | FinalLit FilePath - -- ^ Literal file name. + if null errors + then do + unless (null warns) $ + warn verbosity $ + unlines warns + return $ map unsafeMakeSymbolicPath matches + else rip verbosity $ MatchDirFileGlobErrors errors -reconstructGlob :: Glob -> FilePath -reconstructGlob (GlobStem dir glob) = - dir reconstructGlob glob -reconstructGlob (GlobFinal final) = case final of - FinalMatch Recursive _ exts -> "**" "*" <.> exts - FinalMatch NonRecursive _ exts -> "*" <.> exts - FinalLit path -> path +------------------------------------------------------------------------------- --- | Returns 'Nothing' if the glob didn't match at all, or 'Just' the --- result if the glob matched (or would have matched with a higher --- cabal-version). -fileGlobMatches :: Glob -> FilePath -> Maybe (GlobResult FilePath) -fileGlobMatches pat candidate = do - match <- fileGlobMatchesSegments pat (splitDirectories candidate) - return (candidate <$ match) +-- * Parsing & printing -fileGlobMatchesSegments :: Glob -> [FilePath] -> Maybe (GlobResult ()) -fileGlobMatchesSegments _ [] = Nothing -fileGlobMatchesSegments pat (seg : segs) = case pat of - GlobStem dir pat' -> do - guard (dir == seg) - fileGlobMatchesSegments pat' segs - GlobFinal final -> case final of - FinalMatch Recursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs) - guard (not (null candidateBase)) - checkExt multidot ext candidateExts - FinalMatch NonRecursive multidot ext -> do - let (candidateBase, candidateExts) = splitExtensions seg - guard (null segs && not (null candidateBase)) - checkExt multidot ext candidateExts - FinalLit filename -> do - guard (null segs && filename == seg) - return (GlobMatch ()) +-------------------------------------------------------------------------------- +-- Filepaths with globs may be parsed in the special context is globbing in +-- cabal package fields, such as `data-files`. In that case, we restrict the +-- globbing syntax to that supported by the cabal spec version in use. +-- Otherwise, we parse the globs to the extent of our globbing features +-- (wildcards `*`, unions `{a,b,c}`, and directory-recursive wildcards `**`). -checkExt - :: MultiDot - -> String -- ^ The pattern's extension - -> String -- ^ The candidate file's extension - -> Maybe (GlobResult ()) -checkExt multidot ext candidate - | ext == candidate = Just (GlobMatch ()) - | ext `isSuffixOf` candidate = case multidot of - MultiDotDisabled -> Just (GlobWarnMultiDot ()) - MultiDotEnabled -> Just (GlobMatch ()) - | otherwise = Nothing +-- ** Parsing globs in a cabal package parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob parseFileGlob version filepath = case reverse (splitDirectories filepath) of [] -> - Left EmptyGlob + Left EmptyGlob (filename : "**" : segments) | allowGlobStar -> do - ext <- case splitExtensions filename of - ("*", ext) | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right ext - _ -> Left LiteralFileNameGlobStar - foldM addStem (GlobFinal $ FinalMatch Recursive multidot ext) segments + finalSegment <- case splitExtensions filename of + ("*", ext) + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobDirRecursive [WildCard, Literal ext]) + _ + | allowLiteralFilenameGlobStar -> + Right (GlobDirRecursive [Literal filename]) + | otherwise -> + Left LiteralFileNameGlobStar + + foldM addStem finalSegment segments | otherwise -> Left VersionDoesNotSupportGlobStar (filename : segments) -> do - pat <- case splitExtensions filename of - ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob - | '*' `elem` ext -> Left StarInExtension - | null ext -> Left NoExtensionOnStar - | otherwise -> Right (FinalMatch NonRecursive multidot ext) - (_, ext) | '*' `elem` ext -> Left StarInExtension - | '*' `elem` filename -> Left StarInFileName - | otherwise -> Right (FinalLit filename) - foldM addStem (GlobFinal pat) segments + pat <- case splitExtensions filename of + ("*", ext) + | not allowGlob -> Left VersionDoesNotSupportGlob + | '*' `elem` ext -> Left StarInExtension + | null ext -> Left NoExtensionOnStar + | otherwise -> Right (GlobFile [WildCard, Literal ext]) + (_, ext) + | '*' `elem` ext -> Left StarInExtension + | '*' `elem` filename -> Left StarInFileName + | otherwise -> Right (GlobFile [Literal filename]) + + foldM addStem pat segments where - allowGlob = version >= CabalSpecV1_6 - allowGlobStar = version >= CabalSpecV2_4 addStem pat seg | '*' `elem` seg = Left StarInDirectory - | otherwise = Right (GlobStem seg pat) - multidot - | version >= CabalSpecV2_4 = MultiDotEnabled - | otherwise = MultiDotDisabled + | otherwise = Right (GlobDir [Literal seg] pat) + allowGlob = version >= CabalSpecV1_6 + allowGlobStar = version >= CabalSpecV2_4 + allowLiteralFilenameGlobStar = version >= CabalSpecV3_8 --- | This will 'die'' when the glob matches no files, or if the glob --- refers to a missing directory, or if the glob fails to parse. --- --- The 'Version' argument must be the spec version of the package --- description being processed, as globs behave slightly differently --- in different spec versions. --- --- The first 'FilePath' argument is the directory that the glob is --- relative to. It must be a valid directory (and hence it can't be --- the empty string). The returned values will not include this --- prefix. --- --- The second 'FilePath' is the glob itself. --- -matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob v = matchDirFileGlobWithDie v die' +enableMultidot :: CabalSpecVersion -> Bool +enableMultidot version + | version >= CabalSpecV2_4 = True + | otherwise = False --- | Like 'matchDirFileGlob' but with customizable 'die' --- --- @since 3.6.0.0 --- -matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath] -matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of - Left err -> rip verbosity $ explainGlobSyntaxError filepath err - Right glob -> do - results <- runDirFileGlob verbosity dir glob - let missingDirectories = - [ missingDir | GlobMissingDirectory missingDir <- results ] - matches = globMatches results +-------------------------------------------------------------------------------- +-- Parse and printing utils +-------------------------------------------------------------------------------- - let errors :: [String] - errors = - [ "filepath wildcard '" ++ filepath ++ "' refers to the directory" - ++ " '" ++ missingDir ++ "', which does not exist or is not a directory." - | missingDir <- missingDirectories - ] - ++ - [ "filepath wildcard '" ++ filepath ++ "' does not match any files." - | null matches - ] +-- ** Cabal package globbing errors - if null errors - then return matches - else rip verbosity $ unlines errors +data GlobSyntaxError + = StarInDirectory + | StarInFileName + | StarInExtension + | NoExtensionOnStar + | EmptyGlob + | LiteralFileNameGlobStar + | VersionDoesNotSupportGlobStar + | VersionDoesNotSupportGlob + deriving (Eq, Show) +explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String +explainGlobSyntaxError filepath StarInDirectory = + "invalid file glob '" + ++ filepath + ++ "'. A wildcard '**' is only allowed as the final parent" + ++ " directory. Stars must not otherwise appear in the parent" + ++ " directories." +explainGlobSyntaxError filepath StarInExtension = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' are only allowed as the" + ++ " file's base name, not in the file extension." +explainGlobSyntaxError filepath StarInFileName = + "invalid file glob '" + ++ filepath + ++ "'. Wildcards '*' may only totally replace the" + ++ " file's base name, not only parts of it." +explainGlobSyntaxError filepath NoExtensionOnStar = + "invalid file glob '" + ++ filepath + ++ "'. If a wildcard '*' is used it must be with an file extension." +explainGlobSyntaxError filepath LiteralFileNameGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Prior to 'cabal-version: 3.8'" + ++ " if a wildcard '**' is used as a parent directory, the" + ++ " file's base name must be a wildcard '*'." +explainGlobSyntaxError _ EmptyGlob = + "invalid file glob. A glob cannot be the empty string." +explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar = + "invalid file glob '" + ++ filepath + ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'" + ++ " or greater. Alternatively, for compatibility with earlier Cabal" + ++ " versions, list the included directories explicitly." +explainGlobSyntaxError filepath VersionDoesNotSupportGlob = + "invalid file glob '" + ++ filepath + ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatibility with earlier Cabal " + ++ "versions then list all the files explicitly." + +-- Note throughout that we use splitDirectories, not splitPath. On +-- Posix, this makes no difference, but, because Windows accepts both +-- slash and backslash as its path separators, if we left in the +-- separators from the glob we might not end up properly normalised. + +data GlobResult a + = -- | The glob matched the value supplied. + GlobMatch a + | -- | The glob did not match the value supplied because the + -- cabal-version is too low and the extensions on the file did + -- not precisely match the glob's extensions, but rather the + -- glob was a proper suffix of the file's extensions; i.e., if + -- not for the low cabal-version, it would have matched. + GlobWarnMultiDot a + | -- | The glob couldn't match because the directory named doesn't + -- exist. The directory will be as it appears in the glob (i.e., + -- relative to the directory passed to 'matchDirFileGlob', and, + -- for 'data-files', relative to 'data-dir'). + GlobMissingDirectory a + | -- | The glob matched a directory when we were looking for files only. + -- It didn't match a file! + -- + -- @since 3.12.0.0 + GlobMatchesDirectory a + deriving (Show, Eq, Ord, Functor) + -- | Match files against a pre-parsed glob, starting in a directory. -- -- The 'Version' argument must be the spec version of the package @@ -262,18 +351,24 @@ -- The 'FilePath' argument is the directory that the glob is relative -- to. It must be a valid directory (and hence it can't be the empty -- string). The returned values will not include this prefix. -runDirFileGlob :: Verbosity -> FilePath -> Glob -> IO [GlobResult FilePath] -runDirFileGlob verbosity rawDir pat = do +runDirFileGlob + :: Verbosity + -> Maybe CabalSpecVersion + -- ^ If the glob we are running should care about the cabal spec, and warnings such as 'GlobWarnMultiDot', then this should be the version. + -- If you want to run a glob but don't care about any of the cabal-spec restrictions on globs, use 'Nothing'! + -> FilePath + -> Glob + -> IO [GlobResult FilePath] +runDirFileGlob verbosity mspec rawRoot pat = do -- The default data-dir is null. Our callers -should- be -- converting that to '.' themselves, but it's a certainty that -- some future call-site will forget and trigger a really -- hard-to-debug failure if we don't check for that here. - when (null rawDir) $ + when (null rawRoot) $ warn verbosity $ - "Null dir passed to runDirFileGlob; interpreting it " - ++ "as '.'. This is probably an internal error." - let dir = if null rawDir then "." else rawDir - debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'." + "Null dir passed to runDirFileGlob; interpreting it " + ++ "as '.'. This is probably an internal error." + let root = if null rawRoot then "." else rawRoot -- This function might be called from the project root with dir as -- ".". Walking the tree starting there involves going into .git/ -- and dist-newstyle/, which is a lot of work for no reward, so @@ -281,40 +376,147 @@ -- there, and only walk as much as we need to: recursively if **, -- the whole directory if *, and just the specific file if it's a -- literal. - let (prefixSegments, final) = splitConstantPrefix pat - joinedPrefix = joinPath prefixSegments - case final of - FinalMatch recursive multidot exts -> do - let prefix = dir joinedPrefix - directoryExists <- doesDirectoryExist prefix + let + (prefixSegments, pathOrVariablePattern) = splitConstantPrefix pat + joinedPrefix = joinPath prefixSegments + + -- The glob matching function depends on whether we care about the cabal version or not + doesGlobMatch :: GlobPieces -> String -> Maybe (GlobResult ()) + doesGlobMatch glob str = case mspec of + Just spec -> checkNameMatches spec glob str + Nothing -> if matchGlobPieces glob str then Just (GlobMatch ()) else Nothing + + go (GlobFile glob) dir = do + entries <- getDirectoryContents (root dir) + catMaybes + <$> mapM + ( \s -> do + -- When running a glob from a Cabal package description (i.e. + -- when a cabal spec version is passed as an argument), we + -- disallow matching a @GlobFile@ against a directory, preferring + -- @GlobDir dir GlobDirTrailing@ to specify a directory match. + isFile <- maybe (return True) (const $ doesFileExist (root dir s)) mspec + let match = (dir s <$) <$> doesGlobMatch glob s + return $ + if isFile + then match + else case match of + Just (GlobMatch x) -> Just $ GlobMatchesDirectory x + Just (GlobWarnMultiDot x) -> Just $ GlobMatchesDirectory x + Just (GlobMatchesDirectory x) -> Just $ GlobMatchesDirectory x + Just (GlobMissingDirectory x) -> Just $ GlobMissingDirectory x -- this should never match, unless you are in a file-delete-heavy concurrent setting i guess + Nothing -> Nothing + ) + entries + go (GlobDirRecursive glob) dir = do + entries <- getDirectoryContentsRecursive (root dir) + return $ + mapMaybe + ( \s -> do + globMatch <- doesGlobMatch glob (takeFileName s) + pure ((dir s) <$ globMatch) + ) + entries + go (GlobDir glob globPath) dir = do + entries <- getDirectoryContents (root dir) + subdirs <- + filterM + ( \subdir -> + doesDirectoryExist + (root dir subdir) + ) + $ filter (matchGlobPieces glob) entries + concat <$> traverse (\subdir -> go globPath (dir subdir)) subdirs + go GlobDirTrailing dir = return [GlobMatch dir] + + case pathOrVariablePattern of + Left filename -> do + let filepath = joinedPrefix filename + debug verbosity $ "Treating glob as filepath literal '" ++ filepath ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root filepath) if directoryExists - then do - candidates <- case recursive of - Recursive -> getDirectoryContentsRecursive prefix - NonRecursive -> filterM (doesFileExist . (prefix )) =<< getDirectoryContents prefix - let checkName candidate = do - let (candidateBase, candidateExts) = splitExtensions $ takeFileName candidate - guard (not (null candidateBase)) - match <- checkExt multidot exts candidateExts - return (joinedPrefix candidate <$ match) - return $ mapMaybe checkName candidates - else - return [ GlobMissingDirectory joinedPrefix ] - FinalLit fn -> do - exists <- doesFileExist (dir joinedPrefix fn) - return [ GlobMatch (joinedPrefix fn) | exists ] + then pure [GlobMatchesDirectory filepath] + else do + exist <- doesFileExist (root filepath) + pure $ + if exist + then [GlobMatch filepath] + else [] + Right variablePattern -> do + debug verbosity $ "Expanding glob '" ++ show (pretty pat) ++ "' in directory '" ++ root ++ "'." + directoryExists <- doesDirectoryExist (root joinedPrefix) + if directoryExists + then go variablePattern joinedPrefix + else return [GlobMissingDirectory joinedPrefix] + where + -- \| Extract the (possibly null) constant prefix from the pattern. + -- This has the property that, if @(pref, final) = splitConstantPrefix pat@, + -- then @pat === foldr GlobDir final pref@. + splitConstantPrefix :: Glob -> ([FilePath], Either FilePath Glob) + splitConstantPrefix = fmap literalize . unfoldr' step + where + literalize (GlobFile [Literal filename]) = + Left filename + literalize glob = + Right glob -unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) -unfoldr' f a = case f a of - Left r -> ([], r) - Right (b, a') -> case unfoldr' f a' of - (bs, r) -> (b : bs, r) + step (GlobDir [Literal seg] pat') = Right (seg, pat') + step pat' = Left pat' --- | Extract the (possibly null) constant prefix from the pattern. --- This has the property that, if @(pref, final) = splitConstantPrefix pat@, --- then @pat === foldr GlobStem (GlobFinal final) pref@. -splitConstantPrefix :: Glob -> ([FilePath], GlobFinal) -splitConstantPrefix = unfoldr' step + unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r) + unfoldr' f a = case f a of + Left r -> ([], r) + Right (b, a') -> case unfoldr' f a' of + (bs, r) -> (b : bs, r) + +-- | Is the root of this relative glob path a directory-recursive wildcard, e.g. @**/*.txt@ ? +isRecursiveInRoot :: Glob -> Bool +isRecursiveInRoot (GlobDirRecursive _) = True +isRecursiveInRoot _ = False + +-- | Check how the string matches the glob under this cabal version +checkNameMatches :: CabalSpecVersion -> GlobPieces -> String -> Maybe (GlobResult ()) +checkNameMatches spec glob candidate + -- Check if glob matches in its general form + | matchGlobPieces glob candidate = + -- if multidot is supported, then this is a clean match + if enableMultidot spec + then pure (GlobMatch ()) + else -- if not, issue a warning saying multidot is needed for the match + + let (_, candidateExts) = splitExtensions $ takeFileName candidate + extractExts :: GlobPieces -> Maybe String + extractExts [] = Nothing + extractExts [Literal lit] + -- Any literal terminating a glob, and which does have an extension, + -- returns that extension. Otherwise, recurse until Nothing is returned. + | let ext = takeExtensions lit + , ext /= "" = + Just ext + extractExts (_ : x) = extractExts x + in case extractExts glob of + Just exts + | exts == candidateExts -> + return (GlobMatch ()) + | exts `isSuffixOf` candidateExts -> + return (GlobWarnMultiDot ()) + _ -> return (GlobMatch ()) + | otherwise = empty + +-- | How/does the glob match the given filepath, according to the cabal version? +-- Since this is pure, we don't make a distinction between matching on +-- directories or files (i.e. this function won't return 'GlobMatchesDirectory') +fileGlobMatches :: CabalSpecVersion -> Glob -> FilePath -> Maybe (GlobResult ()) +fileGlobMatches version g path = go g (splitDirectories path) where - step (GlobStem seg pat) = Right (seg, pat) - step (GlobFinal pat) = Left pat + go GlobDirTrailing [] = Just (GlobMatch ()) + go (GlobFile glob) [file] = checkNameMatches version glob file + go (GlobDirRecursive glob) dirs + | [] <- reverse dirs = + Nothing -- @dir/**/x.txt@ should not match @dir/hello@ + | file : _ <- reverse dirs = + checkNameMatches version glob file + go (GlobDir glob globPath) (dir : dirs) = do + _ <- checkNameMatches version glob dir -- we only care if dir segment matches + go globPath dirs + go _ _ = Nothing diff --git a/src/Distribution/Simple/Glob/Internal.hs b/src/Distribution/Simple/Glob/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Glob/Internal.hs @@ -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 + = -- | @/@ + GlobDir !GlobPieces !Glob + | -- | @**/@, where @**@ denotes recursively traversing + -- all directories and matching filenames on . + 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 diff --git a/src/Distribution/Simple/Haddock.hs b/src/Distribution/Simple/Haddock.hs --- a/src/Distribution/Simple/Haddock.hs +++ b/src/Distribution/Simple/Haddock.hs @@ -1,926 +1,1634 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Haddock --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with the @haddock@ and @hscolour@ commands. --- It uses information about installed packages (from @ghc-pkg@) to find the --- locations of documentation for dependent packages, so it can create links. --- --- The @hscolour@ support allows generating HTML versions of the original --- source, with coloured syntax highlighting. - -module Distribution.Simple.Haddock ( - haddock, hscolour, - - haddockPackagePaths - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.GHCJS as GHCJS - --- local -import Distribution.Backpack.DescribeUnitId -import Distribution.Backpack (OpenModule) -import Distribution.Types.ForeignLib -import Distribution.Types.UnqualComponentName -import Distribution.Types.ComponentLocalBuildInfo -import Distribution.Types.ExecutableScope -import Distribution.Types.LocalBuildInfo -import Distribution.Types.TargetInfo -import Distribution.Types.ExposedModule -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Compiler -import Distribution.Simple.Glob -import Distribution.Simple.Program.GHC -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Program -import Distribution.Simple.PreProcess -import Distribution.Simple.Setup -import Distribution.Simple.Build -import Distribution.Simple.BuildTarget -import Distribution.Simple.InstallDirs -import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) -import Distribution.Simple.BuildPaths -import Distribution.Simple.Register -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import qualified Distribution.Simple.PackageIndex as PackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) -import Distribution.Simple.Utils -import Distribution.System -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Utils.NubList -import Distribution.Version -import qualified Distribution.Utils.ShortText as ShortText - -import Distribution.Verbosity -import Language.Haskell.Extension - -import Distribution.Compat.Semigroup (All (..), Any (..)) - -import Control.Monad -import Data.Either ( rights ) - -import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist) -import System.FilePath ( (), (<.>), normalise, isAbsolute ) -import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) - --- ------------------------------------------------------------------------------ --- Types - --- | A record that represents the arguments to the haddock executable, a product --- monoid. -data HaddockArgs = HaddockArgs { - argInterfaceFile :: Flag FilePath, - -- ^ Path to the interface file, relative to argOutputDir, required. - argPackageName :: Flag PackageIdentifier, - -- ^ Package name, required. - argHideModules :: (All,[ModuleName.ModuleName]), - -- ^ (Hide modules ?, modules to hide) - argIgnoreExports :: Any, - -- ^ Ignore export lists in modules? - argLinkSource :: Flag (Template,Template,Template), - -- ^ (Template for modules, template for symbols, template for lines). - argLinkedSource :: Flag Bool, - -- ^ Generate hyperlinked sources - argQuickJump :: Flag Bool, - -- ^ Generate quickjump index - argCssFile :: Flag FilePath, - -- ^ Optional custom CSS file. - argContents :: Flag String, - -- ^ Optional URL to contents page. - argVerbose :: Any, - argOutput :: Flag [Output], - -- ^ HTML or Hoogle doc or both? Required. - argInterfaces :: [(FilePath, Maybe String, Maybe String)], - -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. - argOutputDir :: Directory, - -- ^ Where to generate the documentation. - argTitle :: Flag String, - -- ^ Page title, required. - argPrologue :: Flag String, - -- ^ Prologue text, required. - argGhcOptions :: GhcOptions, - -- ^ Additional flags to pass to GHC. - argGhcLibDir :: Flag FilePath, - -- ^ To find the correct GHC, required. - argReexports :: [OpenModule], - -- ^ Re-exported modules - argTargets :: [FilePath] - -- ^ Modules to process. -} deriving Generic - --- | The FilePath of a directory, it's a monoid under '()'. -newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) - -unDir :: Directory -> FilePath -unDir = normalise . unDir' - -type Template = String - -data Output = Html | Hoogle - --- ------------------------------------------------------------------------------ --- Haddock support - -haddock :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HaddockFlags - -> IO () -haddock pkg_descr _ _ haddockFlags - | not (hasLibs pkg_descr) - && not (fromFlag $ haddockExecutables haddockFlags) - && not (fromFlag $ haddockTestSuites haddockFlags) - && not (fromFlag $ haddockBenchmarks haddockFlags) - && not (fromFlag $ haddockForeignLibs haddockFlags) - = - warn (fromFlag $ haddockVerbosity haddockFlags) $ - "No documentation was generated as this package does not contain " - ++ "a library. Perhaps you want to use the --executables, --tests," - ++ " --benchmarks or --foreign-libraries flags." - -haddock pkg_descr lbi suffixes flags' = do - let verbosity = flag haddockVerbosity - comp = compiler lbi - platform = hostPlatform lbi - - quickJmpFlag = haddockQuickJump flags' - flags = case haddockTarget of - ForDevelopment -> flags' - ForHackage -> flags' - { haddockHoogle = Flag True - , haddockHtml = Flag True - , haddockHtmlLocation = Flag (pkg_url ++ "/docs") - , haddockContents = Flag (toPathTemplate pkg_url) - , haddockLinkedSource = Flag True - , haddockQuickJump = Flag True - } - pkg_url = "/package/$pkg-$version" - flag f = fromFlag $ f flags - - tmpFileOpts = defaultTempFileOptions - { optKeepTempFiles = flag haddockKeepTempFiles } - htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation - $ flags - haddockTarget = - fromFlagOrDefault ForDevelopment (haddockForHackage flags') - - (haddockProg, version, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (mkVersion [2,0])) (withPrograms lbi) - - -- various sanity checks - when (flag haddockHoogle && version < mkVersion [2,2]) $ - die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag." - - - when (flag haddockQuickJump && version < mkVersion [2,19]) $ do - let msg = "Haddock prior to 2.19 does not support the --quickjump flag." - alt = "The generated documentation won't have the QuickJump feature." - if Flag True == quickJmpFlag - then die' verbosity msg - else warn verbosity (msg ++ "\n" ++ alt) - - haddockGhcVersionStr <- getProgramOutput verbosity haddockProg - ["--ghc-version"] - case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of - (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock" - (_, Nothing) -> die' verbosity "Could not get GHC version from compiler" - (Just haddockGhcVersion, Just ghcVersion) - | haddockGhcVersion == ghcVersion -> return () - | otherwise -> die' verbosity $ - "Haddock's internal GHC version must match the configured " - ++ "GHC version.\n" - ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but " - ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion - - -- the tools match the requests, we can proceed - - -- We fall back to using HsColour only for versions of Haddock which don't - -- support '--hyperlinked-sources'. - when (flag haddockLinkedSource && version < mkVersion [2,17]) $ - hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes - (defaultHscolourFlags `mappend` haddockToHscolour flags) - - libdirArgs <- getGhcLibDir verbosity lbi - let commonArgs = mconcat - [ libdirArgs - , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags - , fromPackageDescription haddockTarget pkg_descr ] - - targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags) - - let - targets' = - case targets of - [] -> allTargetsInBuildOrder' pkg_descr lbi - _ -> targets - - internalPackageDB <- - createInternalPackageDB verbosity lbi (flag haddockDistPref) - - (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do - - let component = targetComponent target - clbi = targetCLBI target - - componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity - - let - lbi' = lbi { - withPackageDB = withPackageDB lbi ++ [internalPackageDB], - installedPkgs = index - } - - preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate - version exe - let exeArgs' = commonArgs `mappend` exeArgs - runHaddock verbosity tmpFileOpts comp platform - haddockProg exeArgs' - Nothing -> do - warn (fromFlag $ haddockVerbosity flags) - "Unsupported component, skipping..." - return () - -- We define 'smsg' once and then reuse it inside the case, so that - -- we don't say we are running Haddock when we actually aren't - -- (e.g., Haddock is not run on non-libraries) - smsg :: IO () - smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr) - (componentLocalName clbi) (maybeComponentInstantiatedWith clbi) - case component of - CLib lib -> do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ - \tmp -> do - smsg - libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate - version lib - let libArgs' = commonArgs `mappend` libArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs' - - case libName lib of - LMainLibName -> - pure index - LSubLibName _ -> do - pwd <- getCurrentDirectory - - let - ipi = inplaceInstalledPackageInfo - pwd (flag haddockDistPref) pkg_descr - (mkAbiHash "inplace") lib lbi' clbi - - debug verbosity $ "Registering inplace:\n" - ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) - - registerPackage verbosity (compiler lbi') (withPrograms lbi') - (withPackageDB lbi') ipi - HcPkg.defaultRegisterOptions { - HcPkg.registerMultiInstance = True - } - - return $ PackageIndex.insert ipi index - - CFLib flib -> (when (flag haddockForeignLibs) $ do - withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $ - \tmp -> do - smsg - flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate - version flib - let libArgs' = commonArgs `mappend` flibArgs - runHaddock verbosity tmpFileOpts comp platform haddockProg libArgs') - - >> return index - - CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index - CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index - CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index - - for_ (extraDocFiles pkg_descr) $ \ fpath -> do - files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath - for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs) - --- ------------------------------------------------------------------------------ --- Contributions to HaddockArgs (see also Doctest.hs for very similar code). - -fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs -fromFlags env flags = - mempty { - argHideModules = (maybe mempty (All . not) - $ flagToMaybe (haddockInternal flags), mempty), - argLinkSource = if fromFlag (haddockLinkedSource flags) - then Flag ("src/%{MODULE/./-}.html" - ,"src/%{MODULE/./-}.html#%{NAME}" - ,"src/%{MODULE/./-}.html#line-%{LINE}") - else NoFlag, - argLinkedSource = haddockLinkedSource flags, - argQuickJump = haddockQuickJump flags, - argCssFile = haddockCss flags, - argContents = fmap (fromPathTemplate . substPathTemplate env) - (haddockContents flags), - argVerbose = maybe mempty (Any . (>= deafening)) - . flagToMaybe $ haddockVerbosity flags, - argOutput = - Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ - [ Hoogle | Flag True <- [haddockHoogle flags] ] - of [] -> [ Html ] - os -> os, - argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags, - - argGhcOptions = mempty { ghcOptExtra = ghcArgs } - } - where - ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags - -fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs -fromPackageDescription haddockTarget pkg_descr = mempty - { argInterfaceFile = Flag $ haddockName pkg_descr - , argPackageName = Flag $ packageId $ pkg_descr - , argOutputDir = Dir $ - "doc" "html" haddockDirName haddockTarget pkg_descr - , argPrologue = Flag $ ShortText.fromShortText $ - if ShortText.null desc - then synopsis pkg_descr - else desc - , argTitle = Flag $ showPkg ++ subtitle - } - where - desc = description pkg_descr - showPkg = prettyShow (packageId pkg_descr) - subtitle - | ShortText.null (synopsis pkg_descr) = "" - | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) - -componentGhcOptions :: Verbosity -> LocalBuildInfo - -> BuildInfo -> ComponentLocalBuildInfo -> FilePath - -> GhcOptions -componentGhcOptions verbosity lbi bi clbi odir = - let f = case compilerFlavor (compiler lbi) of - GHC -> GHC.componentGhcOptions - GHCJS -> GHCJS.componentGhcOptions - _ -> error $ - "Distribution.Simple.Haddock.componentGhcOptions:" ++ - "haddock only supports GHC and GHCJS" - in f verbosity lbi bi clbi odir - -mkHaddockArgs :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> [FilePath] - -> BuildInfo - -> IO HaddockArgs -mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do - ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate - let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) { - -- Noooooooooo!!!!!111 - -- haddock stomps on our precious .hi - -- and .o files. Workaround by telling - -- haddock to write them elsewhere. - ghcOptObjDir = toFlag tmp, - ghcOptHiDir = toFlag tmp, - ghcOptStubDir = toFlag tmp - } `mappend` getGhcCppOpts haddockVersion bi - sharedOpts = vanillaOpts { - ghcOptDynLinkMode = toFlag GhcDynamicOnly, - ghcOptFPic = toFlag True, - ghcOptHiSuffix = toFlag "dyn_hi", - ghcOptObjSuffix = toFlag "dyn_o", - ghcOptExtra = hcSharedOptions GHC bi - - } - opts <- if withVanillaLib lbi - then return vanillaOpts - else if withSharedLib lbi - then return sharedOpts - else die' verbosity $ "Must have vanilla or shared libraries " - ++ "enabled in order to run haddock" - - return ifaceArgs - { argGhcOptions = opts - , argTargets = inFiles - , argReexports = getReexports clbi - } - -fromLibrary :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Library - -> IO HaddockArgs -fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do - inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion - inFiles (libBuildInfo lib) - return args { - argHideModules = (mempty, otherModules (libBuildInfo lib)) - } - -fromExecutable :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> Executable - -> IO HaddockArgs -fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do - inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (buildInfo exe) - return args { - argOutputDir = Dir $ unUnqualComponentName $ exeName exe, - argTitle = Flag $ unUnqualComponentName $ exeName exe - } - -fromForeignLib :: Verbosity - -> FilePath - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> Version - -> ForeignLib - -> IO HaddockArgs -fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do - inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi - args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate - haddockVersion inFiles (foreignLibBuildInfo flib) - return args { - argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib, - argTitle = Flag $ unUnqualComponentName $ foreignLibName flib - } - -compToExe :: Component -> Maybe Executable -compToExe comp = - case comp of - CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> - Just Executable { - exeName = testName test, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = testBuildInfo test - } - CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> - Just Executable { - exeName = benchmarkName bench, - modulePath = f, - exeScope = ExecutablePublic, - buildInfo = benchmarkBuildInfo bench - } - CExe exe -> Just exe - _ -> Nothing - -getInterfaces :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate -- ^ template for HTML location - -> IO HaddockArgs -getInterfaces verbosity lbi clbi htmlTemplate = do - (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate - traverse_ (warn (verboseUnmarkOutput verbosity)) warnings - return $ mempty { - argInterfaces = packageFlags - } - -getReexports :: ComponentLocalBuildInfo -> [OpenModule] -getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } = - mapMaybe exposedReexport mods -getReexports _ = [] - -getGhcCppOpts :: Version - -> BuildInfo - -> GhcOptions -getGhcCppOpts haddockVersion bi = - mempty { - ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp], - ghcOptCppOptions = defines - } - where - needsCpp = EnableExtension CPP `elem` usedExtensions bi - defines = [haddockVersionMacro] - haddockVersionMacro = "-D__HADDOCK_VERSION__=" - ++ show (v1 * 1000 + v2 * 10 + v3) - where - (v1, v2, v3) = case versionNumbers haddockVersion of - [] -> (0,0,0) - [x] -> (x,0,0) - [x,y] -> (x,y,0) - (x:y:z:_) -> (x,y,z) - -getGhcLibDir :: Verbosity -> LocalBuildInfo - -> IO HaddockArgs -getGhcLibDir verbosity lbi = do - l <- case compilerFlavor (compiler lbi) of - GHC -> GHC.getLibDir verbosity lbi - GHCJS -> GHCJS.getLibDir verbosity lbi - _ -> error "haddock only supports GHC and GHCJS" - return $ mempty { argGhcLibDir = Flag l } - --- ------------------------------------------------------------------------------ --- | Call haddock with the specified arguments. -runHaddock :: Verbosity - -> TempFileOptions - -> Compiler - -> Platform - -> ConfiguredProgram - -> HaddockArgs - -> IO () -runHaddock verbosity tmpFileOpts comp platform haddockProg args - | null (argTargets args) = warn verbosity $ - "Haddocks are being requested, but there aren't any modules given " - ++ "to create documentation for." - | otherwise = do - let haddockVersion = fromMaybe (error "unable to determine haddock version") - (programVersion haddockProg) - renderArgs verbosity tmpFileOpts haddockVersion comp platform args $ - \(flags,result)-> do - - runProgram verbosity haddockProg flags - - notice verbosity $ "Documentation created: " ++ result - - -renderArgs :: Verbosity - -> TempFileOptions - -> Version - -> Compiler - -> Platform - -> HaddockArgs - -> (([String], FilePath) -> IO a) - -> IO a -renderArgs verbosity tmpFileOpts version comp platform args k = do - let haddockSupportsUTF8 = version >= mkVersion [2,14,4] - haddockSupportsResponseFiles = version > mkVersion [2,16,2] - createDirectoryIfMissingVerbose verbosity True outputDir - withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $ - \prologueFileName h -> do - do - when haddockSupportsUTF8 (hSetEncoding h utf8) - hPutStrLn h $ fromFlag $ argPrologue args - hClose h - let pflag = "--prologue=" ++ prologueFileName - renderedArgs = pflag : renderPureArgs version comp platform args - if haddockSupportsResponseFiles - then - withResponseFile - verbosity - tmpFileOpts - outputDir - "haddock-response.txt" - (if haddockSupportsUTF8 then Just utf8 else Nothing) - renderedArgs - (\responseFileName -> k (["@" ++ responseFileName], result)) - else - k (renderedArgs, result) - where - outputDir = (unDir $ argOutputDir args) - result = intercalate ", " - . map (\o -> outputDir - case o of - Html -> "index.html" - Hoogle -> pkgstr <.> "txt") - $ arg argOutput - where - pkgstr = prettyShow $ packageName pkgid - pkgid = arg argPackageName - arg f = fromFlag $ f args - -renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] -renderPureArgs version comp platform args = concat - [ (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) - . fromFlag . argInterfaceFile $ args - - , if isVersion 2 16 - then (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg) - , "--package-version=" ++ prettyShow (pkgVersion pkg) - ]) - . fromFlag . argPackageName $ args - else [] - - , [ "--since-qual=external" | isVersion 2 20 ] - - , [ "--quickjump" | isVersion 2 19 - , fromFlag . argQuickJump $ args ] - - , [ "--hyperlinked-source" | isVersion 2 17 - , fromFlag . argLinkedSource $ args ] - - , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b) - . argHideModules $ args - - , bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args - - , maybe [] (\(m,e,l) -> - ["--source-module=" ++ m - ,"--source-entity=" ++ e] - ++ if isVersion 2 14 then ["--source-entity-line=" ++ l] - else [] - ) . flagToMaybe . argLinkSource $ args - - , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args - - , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args - - , bool [] [verbosityFlag] . getAny . argVerbose $ args - - , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") - . fromFlag . argOutput $ args - - , renderInterfaces . argInterfaces $ args - - , (:[]) . ("--odir="++) . unDir . argOutputDir $ args - - , (:[]) . ("--title="++) - . (bool (++" (internal documentation)") - id (getAny $ argIgnoreExports args)) - . fromFlag . argTitle $ args - - , [ "--optghc=" ++ opt | let opts = argGhcOptions args - , opt <- renderGhcOptions comp platform opts ] - - , maybe [] (\l -> ["-B"++l]) $ - flagToMaybe (argGhcLibDir args) -- error if Nothing? - - -- https://github.com/haskell/haddock/pull/547 - , [ "--reexport=" ++ prettyShow r - | r <- argReexports args - , isVersion 2 19 - ] - - , argTargets $ args - ] - where - renderInterfaces = map renderInterface - - renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath) -> String - renderInterface (i, html, hypsrc) = "--read-interface=" ++ - (intercalate "," $ concat [ [ x | Just x <- [html] ] - , [ x | Just _ <- [html] - -- only render hypsrc path if html path - -- is given and hyperlinked-source is - -- enabled - , Just x <- [hypsrc] - , isVersion 2 17 - , fromFlag . argLinkedSource $ args - ] - , [ i ] - ]) - - bool a b c = if c then a else b - isVersion major minor = version >= mkVersion [major,minor] - verbosityFlag - | isVersion 2 5 = "--verbosity=1" - | otherwise = "--verbose" - ---------------------------------------------------------------------------------- - --- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and --- HTML paths, and an optional warning for packages with missing documentation. -haddockPackagePaths :: [InstalledPackageInfo] - -> Maybe (InstalledPackageInfo -> FilePath) - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackagePaths ipkgs mkHtmlPath = do - interfaces <- sequenceA - [ case interfaceAndHtmlPath ipkg of - Nothing -> return (Left (packageId ipkg)) - Just (interface, html) -> do - - (html', hypsrc') <- - case html of - Just htmlPath -> do - let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory - hypSrcExists <- doesDirectoryExist hypSrcPath - return $ ( Just (fixFileUrl htmlPath) - , if hypSrcExists - then Just (fixFileUrl hypSrcPath) - else Nothing - ) - Nothing -> return (Nothing, Nothing) - - exists <- doesFileExist interface - if exists - then return (Right (interface, html', hypsrc')) - else return (Left pkgid) - | ipkg <- ipkgs, let pkgid = packageId ipkg - , pkgName pkgid `notElem` noHaddockWhitelist - ] - - let missing = [ pkgid | Left pkgid <- interfaces ] - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map prettyShow missing) - flags = rights interfaces - - return (flags, if null missing then Nothing else Just warning) - - where - -- Don't warn about missing documentation for these packages. See #1231. - noHaddockWhitelist = map mkPackageName [ "rts" ] - - -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. - interfaceAndHtmlPath :: InstalledPackageInfo - -> Maybe (FilePath, Maybe FilePath) - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- case mkHtmlPath of - Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - Just mkPath -> Just (mkPath pkg) - return (interface, if null html then Nothing else Just html) - - -- The 'haddock-html' field in the hc-pkg output is often set as a - -- native path, but we need it as a URL. See #1064. Also don't "fix" - -- the path if it is an interpolated one. - fixFileUrl f | Nothing <- mkHtmlPath - , isAbsolute f = "file://" ++ f - | otherwise = f - - -- 'src' is the default hyperlinked source directory ever since. It is - -- not possible to configure that directory in any way in haddock. - defaultHyperlinkedSourceDirectory = "src" - - -haddockPackageFlags :: Verbosity - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Maybe PathTemplate - -> IO ([( FilePath -- path to interface - -- file - - , Maybe FilePath -- url to html - -- documentation - - , Maybe FilePath -- url to hyperlinked - -- source - )] - , Maybe String -- warning about - -- missing documentation - ) -haddockPackageFlags verbosity lbi clbi htmlTemplate = do - let allPkgs = installedPkgs lbi - directDeps = map fst (componentPackageDeps clbi) - transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of - Left x -> return x - Right inf -> die' verbosity $ "internal error when calculating transitive " - ++ "package dependencies.\nDebug info: " ++ show inf - haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath - where - mkHtmlPath = fmap expandTemplateVars htmlTemplate - expandTemplateVars tmpl pkg = - fromPathTemplate . substPathTemplate (env pkg) $ tmpl - env pkg = haddockTemplateEnv lbi (packageId pkg) - - -haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv -haddockTemplateEnv lbi pkg_id = - (PrefixVar, prefix (installDirTemplates lbi)) - -- We want the legacy unit ID here, because it gives us nice paths - -- (Haddock people don't care about the dependencies) - : initialPathTemplateEnv - pkg_id - (mkLegacyUnitId pkg_id) - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - --- ------------------------------------------------------------------------------ --- hscolour support. - -hscolour :: PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour = hscolour' dieNoVerbosity ForDevelopment - -hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found. - -> HaddockTarget - -> PackageDescription - -> LocalBuildInfo - -> [PPSuffixHandler] - -> HscolourFlags - -> IO () -hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags = - either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<< - lookupProgramVersion verbosity hscolourProgram - (orLaterVersion (mkVersion [1,8])) (withPrograms lbi) - where - go :: ConfiguredProgram -> IO () - go hscolourProg = do - warn verbosity $ - "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++ - "haddock --hyperlink-source' and will be removed in the next major " ++ - "release." - - setupMessage verbosity "Running hscolour for" (packageId pkg_descr) - createDirectoryIfMissingVerbose verbosity True $ - hscolourPref haddockTarget distPref pkg_descr - - withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do - componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity - preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes - let - doExe com = case (compToExe com) of - Just exe -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (exeName exe) "src" - runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi - Nothing -> do - warn (fromFlag $ hscolourVerbosity flags) - "Unsupported component, skipping..." - return () - case comp of - CLib lib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr "src" - runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi - CFLib flib -> do - let outputDir = hscolourPref haddockTarget distPref pkg_descr - unUnqualComponentName (foreignLibName flib) "src" - runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi - CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp - CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp - CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp - - stylesheet = flagToMaybe (hscolourCSS flags) - - verbosity = fromFlag (hscolourVerbosity flags) - distPref = fromFlag (hscolourDistPref flags) - - runHsColour prog outputDir moduleFiles = do - createDirectoryIfMissingVerbose verbosity True outputDir - - case stylesheet of -- copy the CSS file - Nothing | programVersion prog >= Just (mkVersion [1,9]) -> - runProgram verbosity prog - ["-print-css", "-o" ++ outputDir "hscolour.css"] - | otherwise -> return () - Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") - - for_ moduleFiles $ \(m, inFile) -> - runProgram verbosity prog - ["-css", "-anchor", "-o" ++ outFile m, inFile] - where - outFile m = outputDir - intercalate "-" (ModuleName.components m) <.> "html" - -haddockToHscolour :: HaddockFlags -> HscolourFlags -haddockToHscolour flags = - HscolourFlags { - hscolourCSS = haddockHscolourCss flags, - hscolourExecutables = haddockExecutables flags, - hscolourTestSuites = haddockTestSuites flags, - hscolourBenchmarks = haddockBenchmarks flags, - hscolourForeignLibs = haddockForeignLibs flags, - hscolourVerbosity = haddockVerbosity flags, - hscolourDistPref = haddockDistPref flags, - hscolourCabalFilePath = haddockCabalFilePath flags - } - --- ------------------------------------------------------------------------------ --- Boilerplate Monoid instance. -instance Monoid HaddockArgs where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockArgs where - (<>) = gmappend - -instance Monoid Directory where - mempty = Dir "." - mappend = (<>) - -instance Semigroup Directory where - Dir m <> Dir n = Dir $ m n +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. +-- It uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating HTML versions of the original +-- source, with coloured syntax highlighting. +module Distribution.Simple.Haddock + ( haddock + , haddock_setupHooks + , createHaddockIndex + , hscolour + , hscolour_setupHooks + , haddockPackagePaths + , Visibility (..) + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHCJS as GHCJS + +-- local + +import Distribution.Backpack (OpenModule) +import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Semigroup (All (..), Any (..)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import qualified Distribution.ModuleName as ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Parsec (simpleParsec) +import Distribution.Pretty +import Distribution.Simple.Build +import Distribution.Simple.BuildPaths +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag +import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.InstallDirs +import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess +import Distribution.Simple.Program +import Distribution.Simple.Program.GHC +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Register +import Distribution.Simple.Setup +import Distribution.Simple.SetupHooks.Internal + ( BuildHooks (..) + , noBuildHooks + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks +import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ExposedModule +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo +import Distribution.Utils.Path hiding + ( Dir + ) +import qualified Distribution.Utils.Path as Path +import qualified Distribution.Utils.ShortText as ShortText +import Distribution.Verbosity +import Distribution.Version + +import Control.Monad +import Data.Bool (bool) +import Data.Either (rights) +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath (isAbsolute, normalise) +import System.IO (hClose, hPutStrLn, hSetEncoding, utf8) + +-- ------------------------------------------------------------------------------ +-- Types + +-- | A record that represents the arguments to the haddock executable, a product +-- monoid. +data HaddockArgs = HaddockArgs + { argInterfaceFile :: Flag FilePath + -- ^ Path to the interface file, relative to argOutputDir, required. + , argPackageName :: Flag PackageIdentifier + -- ^ Package name, required. + , argComponentName :: Flag String + -- ^ Optional name used to construct haddock's `--package-name` option for + -- various components (tests suites, sublibriaries, etc). + , argHideModules :: (All, [ModuleName.ModuleName]) + -- ^ (Hide modules ?, modules to hide) + , argIgnoreExports :: Any + -- ^ Ignore export lists in modules? + , argLinkSource :: Flag (Template, Template, Template) + -- ^ (Template for modules, template for symbols, template for lines). + , argLinkedSource :: Flag Bool + -- ^ Generate hyperlinked sources + , argQuickJump :: Flag Bool + -- ^ Generate quickjump index + , argCssFile :: Flag FilePath + -- ^ Optional custom CSS file. + , argContents :: Flag String + -- ^ Optional URL to contents page. + , argGenContents :: Flag Bool + -- ^ Generate contents + , argIndex :: Flag String + -- ^ Optional URL to index page. + , argGenIndex :: Flag Bool + -- ^ Generate index + , argBaseUrl :: Flag String + -- ^ Optional base url from which static files will be loaded. + , argVerbose :: Any + , argOutput :: Flag [Output] + -- ^ HTML or Hoogle doc or both? Required. + , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)] + -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)]. + , argOutputDir :: Directory + -- ^ Where to generate the documentation. + , argTitle :: Flag String + -- ^ Page title, required. + , argPrologue :: Flag String + -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'. + , argPrologueFile :: Flag FilePath + -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'. + , argGhcOptions :: GhcOptions + -- ^ Additional flags to pass to GHC. + , argGhcLibDir :: Flag FilePath + -- ^ To find the correct GHC, required. + , argReexports :: [OpenModule] + -- ^ Re-exported modules + , argTargets :: [FilePath] + -- ^ Modules to process. + , argResourcesDir :: Flag String + -- ^ haddock's static \/ auxiliary files. + , argUseUnicode :: Flag Bool + -- ^ haddock's `--use-unicode` flag + } + deriving (Generic) + +-- | The FilePath of a directory, it's a monoid under '()'. +newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord) + +-- NB: only correct at the top-level, after we have combined monoidally +-- the top-level output directory with the component subdir. +unDir :: Directory -> SymbolicPath Pkg (Path.Dir Artifacts) +unDir = makeSymbolicPath . normalise . unDir' + +type Template = String + +data Output = Html | Hoogle + deriving (Eq) + +-- ------------------------------------------------------------------------------ +-- Haddock support + +-- | Get Haddock program and check if it matches the request +getHaddockProg + :: Verbosity + -> ProgramDb + -> Compiler + -> HaddockArgs + -> Flag Bool + -- ^ quickjump feature + -> IO (ConfiguredProgram, Version) +getHaddockProg verbosity programDb comp args quickJumpFlag = do + let HaddockArgs + { argQuickJump + , argOutput + } = args + hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput + + (haddockProg, version, _) <- + requireProgramVersion + verbosity + haddockProgram + (orLaterVersion (mkVersion [2, 0])) + programDb + + -- various sanity checks + when (hoogle && version < mkVersion [2, 2]) $ + dieWithException verbosity NoSupportForHoogle + + when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do + let msg = "Haddock prior to 2.19 does not support the --quickjump flag." + alt = "The generated documentation won't have the QuickJump feature." + if Flag True == quickJumpFlag + then dieWithException verbosity NoSupportForQuickJumpFlag + else warn verbosity (msg ++ "\n" ++ alt) + + haddockGhcVersionStr <- + getProgramOutput + verbosity + haddockProg + ["--ghc-version"] + case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of + (Nothing, _) -> dieWithException verbosity NoGHCVersionFromHaddock + (_, Nothing) -> dieWithException verbosity NoGHCVersionFromCompiler + (Just haddockGhcVersion, Just ghcVersion) + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> dieWithException verbosity $ HaddockAndGHCVersionDoesntMatch ghcVersion haddockGhcVersion + + return (haddockProg, version) + +haddock + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock = haddock_setupHooks noBuildHooks + +haddock_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HaddockFlags + -> IO () +haddock_setupHooks + _ + pkg_descr + _ + _ + haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) + && not (fromFlag $ haddockTestSuites haddockFlags) + && not (fromFlag $ haddockBenchmarks haddockFlags) + && not (fromFlag $ haddockForeignLibs haddockFlags) = + warn (fromFlag $ setupVerbosity $ haddockCommonFlags haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables, --tests," + ++ " --benchmarks or --foreign-libraries flags." +haddock_setupHooks + (BuildHooks{preBuildComponentRules = mbPbcRules}) + pkg_descr + lbi + suffixes + flags' = do + let verbosity = fromFlag $ haddockVerbosity flags + mbWorkDir = flagToMaybe $ haddockWorkingDir flags + comp = compiler lbi + platform = hostPlatform lbi + config = configFlags lbi + + quickJmpFlag = haddockQuickJump flags' + flags = case haddockTarget of + ForDevelopment -> flags' + ForHackage -> + flags' + { haddockHoogle = Flag True + , haddockHtml = Flag True + , haddockHtmlLocation = Flag (pkg_url ++ "/docs") + , haddockContents = Flag (toPathTemplate pkg_url) + , haddockLinkedSource = Flag True + , haddockQuickJump = Flag True + } + pkg_url = "/package/$pkg-$version" + flag f = fromFlag $ f flags + + tmpFileOpts = + commonSetupTempFileOptions $ configCommonFlags config + htmlTemplate = + fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ + flags + haddockTarget = + fromFlagOrDefault ForDevelopment (haddockForHackage flags') + + libdirArgs <- getGhcLibDir verbosity lbi + -- The haddock-output-dir flag overrides any other documentation placement concerns. + -- The point is to give the user full freedom over the location if they need it. + let overrideWithOutputDir args = case haddockOutputDir flags of + NoFlag -> args + Flag dir -> args{argOutputDir = Dir dir} + let commonArgs = + overrideWithOutputDir $ + mconcat + [ libdirArgs + , fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags + , fromPackageDescription haddockTarget pkg_descr + ] + + (haddockProg, version) <- + getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag + + -- We fall back to using HsColour only for versions of Haddock which don't + -- support '--hyperlinked-sources'. + let using_hscolour = flag haddockLinkedSource && version < mkVersion [2, 17] + when using_hscolour $ + hscolour' + noBuildHooks + -- NB: we are not passing the user BuildHooks here, + -- because we are already running the pre/post build hooks + -- for Haddock. + (warn verbosity) + haddockTarget + pkg_descr + lbi + suffixes + (defaultHscolourFlags `mappend` haddockToHscolour flags) + + targets <- readTargetInfos verbosity pkg_descr lbi (haddockTargets flags) + + let + targets' = + case targets of + [] -> allTargetsInBuildOrder' pkg_descr lbi + _ -> targets + + internalPackageDB <- + createInternalPackageDB verbosity lbi (flag $ setupDistPref . haddockCommonFlags) + + (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do + curDir <- absoluteWorkingDirLBI lbi + let + component = targetComponent target + clbi = targetCLBI target + bi = componentBuildInfo component + -- Include any build-tool-depends on build tools internal to the current package. + progs' = addInternalBuildTools curDir pkg_descr lbi bi (withPrograms lbi) + lbi' = + lbi + { withPrograms = progs' + , withPackageDB = withPackageDB lbi ++ [internalPackageDB] + , installedPkgs = index + } + + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 tgt = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHaddock flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = tgt + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + + -- See Note [Hi Haddock Recompilation Avoidance] + reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version $ \haddockArtifactsDirs -> do + preBuildComponent runPreBuildHooks verbosity lbi' target + preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + exeArgs <- + fromExecutable + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + exe + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + exeArgs + Nothing -> do + warn + verbosity + "Unsupported component, skipping..." + return () + -- We define 'smsg' once and then reuse it inside the case, so that + -- we don't say we are running Haddock when we actually aren't + -- (e.g., Haddock is not run on non-libraries) + smsg :: IO () + smsg = + setupMessage' + verbosity + "Running Haddock on" + (packageId pkg_descr) + (componentLocalName clbi) + (maybeComponentInstantiatedWith clbi) + ipi <- case component of + CLib lib -> do + smsg + libArgs <- + fromLibrary + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + lib + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + libArgs + inplaceDir <- absoluteWorkingDirLBI lbi + + let + ipi = + inplaceInstalledPackageInfo + inplaceDir + (flag $ setupDistPref . haddockCommonFlags) + pkg_descr + (mkAbiHash "inplace") + lib + lbi' + clbi + + debug verbosity $ + "Registering inplace:\n" + ++ (InstalledPackageInfo.showInstalledPackageInfo ipi) + + registerPackage + verbosity + (compiler lbi') + (withPrograms lbi') + mbWorkDir + (withPackageDB lbi') + ipi + HcPkg.defaultRegisterOptions + { HcPkg.registerMultiInstance = True + } + + return $ PackageIndex.insert ipi index + CFLib flib -> + when + (flag haddockForeignLibs) + ( do + smsg + flibArgs <- + fromForeignLib + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + flib + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + flibArgs + ) + >> return index + CExe _ -> when (flag haddockExecutables) (smsg >> doExe component) >> return index + CTest test -> do + when (flag haddockTestSuites) $ do + smsg + testArgs <- + fromTest + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + test + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + testArgs + return index + CBench bench -> do + when (flag haddockBenchmarks) $ do + smsg + benchArgs <- + fromBenchmark + verbosity + haddockArtifactsDirs + lbi' + clbi + htmlTemplate + haddockTarget + pkg_descr + bench + commonArgs + runHaddock + verbosity + mbWorkDir + tmpFileOpts + comp + platform + haddockProg + True + benchArgs + return index + + return ipi + + for_ (extraDocFiles pkg_descr) $ \fpath -> do + files <- matchDirFileGlob verbosity (specVersion pkg_descr) mbWorkDir fpath + let targetDir = Dir $ unDir' (argOutputDir commonArgs) haddockDirName haddockTarget pkg_descr + for_ files $ + copyFileToCwd verbosity mbWorkDir (unDir targetDir) + +-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build +-- index and contents for documentation of multiple packages. +createHaddockIndex + :: Verbosity + -> ProgramDb + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> HaddockProjectFlags + -> IO () +createHaddockIndex verbosity programDb comp platform mbWorkDir flags = do + let args = fromHaddockProjectFlags flags + tmpFileOpts = + commonSetupTempFileOptions $ haddockProjectCommonFlags $ flags + (haddockProg, _version) <- + getHaddockProg verbosity programDb comp args (Flag True) + runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg False args + +-- ------------------------------------------------------------------------------ +-- Contributions to HaddockArgs (see also Doctest.hs for very similar code). + +fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs +fromFlags env flags = + mempty + { argHideModules = + ( maybe mempty (All . not) $ + flagToMaybe (haddockInternal flags) + , mempty + ) + , argLinkSource = + if fromFlag (haddockLinkedSource flags) + then + Flag + ( "src/%{MODULE/./-}.html" + , "src/%{MODULE/./-}.html#%{NAME}" + , "src/%{MODULE/./-}.html#line-%{LINE}" + ) + else NoFlag + , argLinkedSource = haddockLinkedSource flags + , argQuickJump = haddockQuickJump flags + , argCssFile = haddockCss flags + , argContents = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockContents flags) + , argGenContents = Flag False + , argIndex = + fmap + (fromPathTemplate . substPathTemplate env) + (haddockIndex flags) + , argGenIndex = Flag False + , argBaseUrl = haddockBaseUrl flags + , argResourcesDir = haddockResourcesDir flags + , argVerbose = + maybe mempty (Any . (>= deafening)) + . flagToMaybe + $ setupVerbosity commonFlags + , argOutput = + Flag $ case [Html | Flag True <- [haddockHtml flags]] + ++ [Hoogle | Flag True <- [haddockHoogle flags]] of + [] -> [Html] + os -> os + , argOutputDir = maybe mempty (Dir . getSymbolicPath) . flagToMaybe $ setupDistPref commonFlags + , argGhcOptions = mempty{ghcOptExtra = ghcArgs} + , argUseUnicode = haddockUseUnicode flags + } + where + ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags + commonFlags = haddockCommonFlags flags + +fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs +fromHaddockProjectFlags flags = + mempty + { argOutputDir = Dir (fromFlag $ haddockProjectDir flags) + , argQuickJump = Flag True + , argGenContents = Flag True + , argGenIndex = Flag True + , argPrologueFile = haddockProjectPrologue flags + , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags) + , argLinkedSource = Flag True + , argResourcesDir = haddockProjectResourcesDir flags + , argCssFile = haddockProjectCss flags + } + +fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs +fromPackageDescription _haddockTarget pkg_descr = + mempty + { argInterfaceFile = Flag $ haddockPath pkg_descr + , argPackageName = Flag $ packageId $ pkg_descr + , argOutputDir = Dir $ "doc" "html" + , argPrologue = + Flag $ + ShortText.fromShortText $ + if ShortText.null desc + then synopsis pkg_descr + else desc + , argTitle = Flag $ showPkg ++ subtitle + } + where + desc = description pkg_descr + showPkg = prettyShow (packageId pkg_descr) + subtitle + | ShortText.null (synopsis pkg_descr) = "" + | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr) + +componentGhcOptions + :: Verbosity + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Path.Dir build) + -> GhcOptions +componentGhcOptions verbosity lbi bi clbi odir = + let f = case compilerFlavor (compiler lbi) of + GHC -> GHC.componentGhcOptions + GHCJS -> GHCJS.componentGhcOptions + _ -> + error $ + "Distribution.Simple.Haddock.componentGhcOptions:" + ++ "haddock only supports GHC and GHCJS" + in f verbosity lbi bi clbi odir + +{- +Note [Hi Haddock Recompilation Avoidance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Starting with Haddock 2.28, we no longer want to run Haddock's GHC session in +an arbitrary temporary directory. Doing so always causes recompilation during +documentation generation, which can now be avoided thanks to Hi Haddock. + +Instead, we want to re-use the interface and object files produced by GHC. +We copy these intermediate files produced by GHC to temporary directories and +point haddock to them. + +The reason why we can't use the GHC files /inplace/ is that haddock may have to +recompile (e.g. because of `haddock-options`). In that case, we want to be sure +the files produced by GHC do not get overwritten. + +See https://github.com/haskell/cabal/pull/9177 for discussion. + +(W.1) As it turns out, -stubdir is included in GHC's recompilation fingerprint. +This means that if we use a temporary directory for stubfiles produced by GHC +for the haddock invocation, haddock will trigger full recompilation since the +stubdir would be different. + +So we don't use a temporary stubdir, despite the tmp o-dir and hi-dir: + +We want to avoid at all costs haddock accidentally overwriting o-files and +hi-files (e.g. if a user specified haddock-option triggers recompilation), and +thus copy them to a temporary directory to pass them on to haddock. However, +stub files are much less problematic since ABI-incompatibility isn't at play +here, that is, there doesn't seem to be a GHC flag that could accidentally make +a stub file incompatible with the one produced by GHC from the same module. +-} + +mkHaddockArgs + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> [SymbolicPath Pkg File] + -> BuildInfo + -> IO HaddockArgs +mkHaddockArgs verbosity (tmpObjDir, tmpHiDir, tmpStubDir) lbi clbi htmlTemplate inFiles bi = do + let + vanillaOpts' = + componentGhcOptions normal lbi bi clbi (buildDir lbi) + vanillaOpts = + vanillaOpts' + { -- See Note [Hi Haddock Recompilation Avoidance] + ghcOptObjDir = toFlag tmpObjDir + , ghcOptHiDir = toFlag tmpHiDir + , ghcOptStubDir = toFlag tmpStubDir + } + sharedOpts = + vanillaOpts + { ghcOptDynLinkMode = toFlag GhcDynamicOnly + , ghcOptFPic = toFlag True + , ghcOptHiSuffix = toFlag "dyn_hi" + , ghcOptObjSuffix = toFlag "dyn_o" + , ghcOptExtra = hcSharedOptions GHC bi + } + ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate + opts <- + if withVanillaLib lbi + then return vanillaOpts + else + if withSharedLib lbi + then return sharedOpts + else dieWithException verbosity MustHaveSharedLibraries + + return + ifaceArgs + { argGhcOptions = opts + , argTargets = map getSymbolicPath inFiles + , argReexports = getReexports clbi + } + +fromLibrary + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Library + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromLibrary verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr lib commonArgs = do + inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (libBuildInfo lib) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ haddockLibraryDirPath haddockTarget pkg_descr lib + , argInterfaceFile = Flag $ haddockLibraryPath pkg_descr lib + } + args'' = + args' + { argHideModules = (mempty, otherModules (libBuildInfo lib)) + , argTitle = Flag $ haddockPackageLibraryName pkg_descr lib + , argComponentName = toFlag (haddockPackageLibraryName' (pkgName (package pkg_descr)) (libName lib)) + , -- we need to accommodate for `argOutputDir`, see `haddockLibraryPath` + argBaseUrl = case (libName lib, argBaseUrl args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + , argContents = case (libName lib, argContents args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + , argIndex = case (libName lib, argIndex args') of + (LSubLibName _, Flag url) -> Flag $ ".." url + (_, a) -> a + } + return args'' + +fromExecutable + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Executable + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromExecutable verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr exe commonArgs = do + inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (buildInfo exe) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (exeName exe) + } + return + args' + { argTitle = Flag $ unUnqualComponentName $ exeName exe + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromTest + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> TestSuite + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromTest verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr test commonArgs = do + inFiles <- map snd `fmap` getTestSourceFiles verbosity lbi test clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (testBuildInfo test) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (testName test) + } + return + args' + { argTitle = Flag $ prettyShow (packageName pkg_descr) + , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (testName test) + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromBenchmark + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> Benchmark + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromBenchmark verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr bench commonArgs = do + inFiles <- map snd `fmap` getBenchmarkSourceFiles verbosity lbi bench clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (benchmarkBuildInfo bench) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (benchmarkName bench) + } + return + args' + { argTitle = Flag $ prettyShow (packageName pkg_descr) + , argComponentName = Flag $ prettyShow (packageName pkg_descr) ++ ":" ++ unUnqualComponentName (benchmarkName bench) + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +fromForeignLib + :: Verbosity + -> (SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) + -- ^ Directories for -hidir, -odir, and -stubdir to GHC through Haddock. + -- See Note [Hi Haddock Recompilation Avoidance] + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> HaddockTarget + -> PackageDescription + -> ForeignLib + -> HaddockArgs + -- ^ common args + -> IO HaddockArgs +fromForeignLib verbosity haddockArtifactsDirs lbi clbi htmlTemplate haddockTarget pkg_descr flib commonArgs = do + inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi + args <- + mkHaddockArgs + verbosity + haddockArtifactsDirs + lbi + clbi + htmlTemplate + inFiles + (foreignLibBuildInfo flib) + let args' = + commonArgs + <> args + { argOutputDir = + Dir $ + haddockDirName haddockTarget pkg_descr + unUnqualComponentName (foreignLibName flib) + } + return + args' + { argTitle = Flag $ unUnqualComponentName $ foreignLibName flib + , -- we need to accommodate `argOutputDir` + argBaseUrl = case argBaseUrl args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argContents = case argContents args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + , argIndex = case argIndex args' of + Flag url -> Flag $ ".." url + NoFlag -> NoFlag + } + +compToExe :: Component -> Maybe Executable +compToExe comp = + case comp of + CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} -> + Just + Executable + { exeName = testName test + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = testBuildInfo test + } + CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} -> + Just + Executable + { exeName = benchmarkName bench + , modulePath = f + , exeScope = ExecutablePublic + , buildInfo = benchmarkBuildInfo bench + } + CExe exe -> Just exe + _ -> Nothing + +getInterfaces + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -- ^ template for HTML location + -> IO HaddockArgs +getInterfaces verbosity lbi clbi htmlTemplate = do + (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate + traverse_ (warn (verboseUnmarkOutput verbosity)) warnings + return $ + mempty + { argInterfaces = packageFlags + } + +getReexports :: ComponentLocalBuildInfo -> [OpenModule] +getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} = + mapMaybe exposedReexport mods +getReexports _ = [] + +getGhcLibDir + :: Verbosity + -> LocalBuildInfo + -> IO HaddockArgs +getGhcLibDir verbosity lbi = do + l <- case compilerFlavor (compiler lbi) of + GHC -> GHC.getLibDir verbosity lbi + GHCJS -> GHCJS.getLibDir verbosity lbi + _ -> error "haddock only supports GHC and GHCJS" + return $ mempty{argGhcLibDir = Flag l} + +-- | If Hi Haddock is supported, this function creates temporary directories +-- and copies existing interface and object files produced by GHC into them, +-- then passes them off to the given continuation. +-- +-- If Hi Haddock is _not_ supported, we can't re-use GHC's compilation files. +-- Instead, we use a clean temporary directory to the continuation, +-- with no hope for recompilation avoidance. +-- +-- See Note [Hi Haddock Recompilation Avoidance] +reusingGHCCompilationArtifacts + :: Verbosity + -> TempFileOptions + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -- ^ Working directory + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> Version + -- ^ Haddock's version + -> ((SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts), SymbolicPath Pkg (Path.Dir Artifacts)) -> IO r) + -- ^ Continuation + -> IO r +reusingGHCCompilationArtifacts verbosity tmpFileOpts mbWorkDir lbi bi clbi version act + | version >= mkVersion [2, 28, 0] = do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-objs" $ \tmpObjDir -> + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "haddock-his" $ \tmpHiDir -> do + -- Re-use ghc's interface and obj files, but first copy them to + -- somewhere where it is safe if haddock overwrites them + let + vanillaOpts = componentGhcOptions normal lbi bi clbi (buildDir lbi) + i = interpretSymbolicPath mbWorkDir + copyDir getGhcDir tmpDir = do + let ghcDir = i $ fromFlag $ getGhcDir vanillaOpts + ghcDirExists <- doesDirectoryExist ghcDir + -- Don't try to copy artifacts if they don't exist, e.g. if + -- we have not yet run the 'build' command. + when ghcDirExists $ + copyDirectoryRecursive verbosity ghcDir (i tmpDir) + copyDir ghcOptObjDir tmpObjDir + copyDir ghcOptHiDir tmpHiDir + -- copyDir ghcOptStubDir tmpStubDir -- (see W.1 in Note [Hi Haddock Recompilation Avoidance]) + + act (tmpObjDir, tmpHiDir, fromFlag $ ghcOptHiDir vanillaOpts) + | otherwise = do + withTempDirectoryCwdEx verbosity tmpFileOpts mbWorkDir (distPrefLBI lbi) "tmp" $ + \tmpFallback -> act (tmpFallback, tmpFallback, tmpFallback) + +-- ------------------------------------------------------------------------------ + +-- | Call haddock with the specified arguments. +runHaddock + :: Verbosity + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> TempFileOptions + -> Compiler + -> Platform + -> ConfiguredProgram + -> Bool + -- ^ require targets + -> HaddockArgs + -> IO () +runHaddock verbosity mbWorkDir tmpFileOpts comp platform haddockProg requireTargets args + | requireTargets && null (argTargets args) = + warn verbosity $ + "Haddocks are being requested, but there aren't any modules given " + ++ "to create documentation for." + | otherwise = do + let haddockVersion = + fromMaybe + (error "unable to determine haddock version") + (programVersion haddockProg) + renderArgs verbosity mbWorkDir tmpFileOpts haddockVersion comp platform args $ + \flags result -> do + runProgramCwd verbosity mbWorkDir haddockProg flags + notice verbosity $ "Documentation created: " ++ result + +renderArgs + :: forall a + . Verbosity + -> Maybe (SymbolicPath CWD (Path.Dir Pkg)) + -> TempFileOptions + -> Version + -> Compiler + -> Platform + -> HaddockArgs + -> ([String] -> FilePath -> IO a) + -> IO a +renderArgs verbosity mbWorkDir tmpFileOpts version comp platform args k = do + let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4] + haddockSupportsResponseFiles = version > mkVersion [2, 16, 2] + createDirectoryIfMissingVerbose verbosity True (i outputDir) + let withPrologueArgs prologueArgs = + let renderedArgs = prologueArgs <> renderPureArgs version comp platform args + in if haddockSupportsResponseFiles + then + withResponseFile + verbosity + tmpFileOpts + "haddock-response.txt" + (if haddockSupportsUTF8 then Just utf8 else Nothing) + renderedArgs + (\responseFileName -> k ["@" ++ responseFileName] result) + else k renderedArgs result + case (argPrologueFile args, argPrologue args) of + (Flag pfile, _) -> + withPrologueArgs ["--prologue=" ++ pfile] + (_, Flag prologueText) -> + withTempFileEx tmpFileOpts "haddock-prologue.txt" $ + \prologueFileName h -> do + when haddockSupportsUTF8 (hSetEncoding h utf8) + hPutStrLn h prologueText + hClose h + withPrologueArgs ["--prologue=" ++ u prologueFileName] + (NoFlag, NoFlag) -> + withPrologueArgs [] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + outputDir = coerceSymbolicPath $ unDir $ argOutputDir args + isNotArgContents = isNothing (flagToMaybe $ argContents args) + isNotArgIndex = isNothing (flagToMaybe $ argIndex args) + isArgGenIndex = fromFlagOrDefault False (argGenIndex args) + -- Haddock, when generating HTML, does not generate an index if the options + -- --use-contents or --use-index are passed to it. See + -- https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-use-contents + isIndexGenerated = isArgGenIndex && isNotArgContents && isNotArgIndex + result = + intercalate ", " + . map + ( \o -> + i outputDir + case o of + Html + | isIndexGenerated -> + "index.html" + Html + | otherwise -> + mempty + Hoogle -> pkgstr <.> "txt" + ) + . fromFlagOrDefault [Html] + . argOutput + $ args + where + pkgstr = prettyShow $ packageName pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String] +renderPureArgs version comp platform args = + concat + [ map (\f -> "--dump-interface=" ++ u (unDir (argOutputDir args)) f) + . flagToList + . argInterfaceFile + $ args + , if haddockSupportsPackageName + then + maybe + [] + ( \pkg -> + [ "--package-name=" + ++ case argComponentName args of + Flag name -> name + _ -> prettyShow (pkgName pkg) + , "--package-version=" ++ prettyShow (pkgVersion pkg) + ] + ) + . flagToMaybe + . argPackageName + $ args + else [] + , ["--since-qual=external" | isVersion 2 20] + , [ "--quickjump" | isVersion 2 19, True <- flagToList . argQuickJump $ args + ] + , ["--hyperlinked-source" | isHyperlinkedSource] + , (\(All b, xs) -> bool [] (map (("--hide=" ++) . prettyShow) xs) b) + . argHideModules + $ args + , bool [] ["--ignore-all-exports"] . getAny . argIgnoreExports $ args + , -- Haddock's --source-* options are ignored once --hyperlinked-source is + -- set. + -- See https://haskell-haddock.readthedocs.io/en/latest/invoking.html#cmdoption-hyperlinked-source + -- To avoid Haddock's warning, we only set --source-* options if + -- --hyperlinked-source is not set. + if isHyperlinkedSource + then [] + else + maybe + [] + ( \(m, e, l) -> + [ "--source-module=" ++ m + , "--source-entity=" ++ e + ] + ++ if isVersion 2 14 + then ["--source-entity-line=" ++ l] + else [] + ) + . flagToMaybe + . argLinkSource + $ args + , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args + , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args + , bool [] ["--gen-contents"] . fromFlagOrDefault False . argGenContents $ args + , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args + , bool [] ["--gen-index"] . fromFlagOrDefault False . argGenIndex $ args + , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args + , bool [verbosityFlag] [] . getAny . argVerbose $ args + , map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") + . fromFlagOrDefault [] + . argOutput + $ args + , renderInterfaces . argInterfaces $ args + , (: []) . ("--odir=" ++) . u . unDir . argOutputDir $ args + , maybe + [] + ( (: []) + . ("--title=" ++) + . ( bool + id + (++ " (internal documentation)") + (getAny $ argIgnoreExports args) + ) + ) + . flagToMaybe + . argTitle + $ args + , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts + ] + , maybe [] (\l -> ["-B" ++ l]) $ + flagToMaybe (argGhcLibDir args) -- error if Nothing? + , -- https://github.com/haskell/haddock/pull/547 + [ "--reexport=" ++ prettyShow r + | r <- argReexports args + , isVersion 2 19 + ] + , argTargets $ args + , maybe [] ((: []) . (resourcesDirFlag ++)) . flagToMaybe . argResourcesDir $ args + , -- Do not re-direct compilation output to a temporary directory (--no-tmp-comp-dir) + -- We pass this option by default to haddock to avoid recompilation + -- See Note [Hi Haddock Recompilation Avoidance] + ["--no-tmp-comp-dir" | version >= mkVersion [2, 28, 0]] + , bool [] ["--use-unicode"] . fromFlagOrDefault False . argUseUnicode $ args + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u = interpretSymbolicPathCWD + renderInterfaces = map renderInterface + + renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String + renderInterface (i, html, hypsrc, visibility) = + "--read-interface=" + ++ intercalate + "," + ( concat + [ [fromMaybe "" html] + , -- only render hypsrc path if html path + -- is given and hyperlinked-source is + -- enabled + + [ case (html, hypsrc) of + (Nothing, _) -> "" + (_, Nothing) -> "" + (_, Just x) + | isVersion 2 17 + , fromFlagOrDefault False . argLinkedSource $ args -> + x + | otherwise -> + "" + ] + , if haddockSupportsVisibility + then + [ case visibility of + Visible -> "visible" + Hidden -> "hidden" + ] + else [] + , [i] + ] + ) + + isVersion major minor = version >= mkVersion [major, minor] + verbosityFlag + | isVersion 2 5 = "--verbosity=1" + | otherwise = "--verbose" + resourcesDirFlag + | isVersion 2 29 = "--resources-dir=" + | otherwise = "--lib=" + haddockSupportsVisibility = version >= mkVersion [2, 26, 1] + haddockSupportsPackageName = version > mkVersion [2, 16] + haddockSupportsHyperlinkedSource = isVersion 2 17 + isHyperlinkedSource = + haddockSupportsHyperlinkedSource + && fromFlagOrDefault False (argLinkedSource args) + +--------------------------------------------------------------------------------- + +-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and +-- HTML paths, and an optional warning for packages with missing documentation. +haddockPackagePaths + :: [InstalledPackageInfo] + -> Maybe (InstalledPackageInfo -> FilePath) + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackagePaths ipkgs mkHtmlPath = do + interfaces <- + sequenceA + [ case interfaceAndHtmlPath ipkg of + Nothing -> do + return (Left (packageId ipkg)) + Just (interface, html) -> do + (html', hypsrc') <- + case html of + Just htmlPath -> do + let hypSrcPath = htmlPath defaultHyperlinkedSourceDirectory + hypSrcExists <- doesDirectoryExist hypSrcPath + return $ + ( Just (fixFileUrl htmlPath) + , if hypSrcExists + then Just (fixFileUrl hypSrcPath) + else Nothing + ) + Nothing -> return (Nothing, Nothing) + + exists <- doesFileExist interface + if exists + then return (Right (interface, html', hypsrc', Visible)) + else return (Left pkgid) + | ipkg <- ipkgs + , let pkgid = packageId ipkg + , pkgName pkgid `notElem` noHaddockWhitelist + ] + + let missing = [pkgid | Left pkgid <- interfaces] + warning = + "The following packages have no Haddock documentation " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map prettyShow missing) + flags = rights interfaces + + return (flags, if null missing then Nothing else Just warning) + where + -- Don't warn about missing documentation for these packages. See #1231. + noHaddockWhitelist = map mkPackageName ["rts"] + + -- Actually extract interface and HTML paths from an 'InstalledPackageInfo'. + interfaceAndHtmlPath + :: InstalledPackageInfo + -> Maybe (FilePath, Maybe FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case mkHtmlPath of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just mkPath -> Just (mkPath pkg) + return (interface, if null html then Nothing else Just html) + + -- The 'haddock-html' field in the hc-pkg output is often set as a + -- native path, but we need it as a URL. See #1064. Also don't "fix" + -- the path if it is an interpolated one. + fixFileUrl f + | Nothing <- mkHtmlPath + , isAbsolute f = + "file://" ++ f + | otherwise = f + + -- 'src' is the default hyperlinked source directory ever since. It is + -- not possible to configure that directory in any way in haddock. + defaultHyperlinkedSourceDirectory = "src" + +haddockPackageFlags + :: Verbosity + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Maybe PathTemplate + -> IO + ( [ ( FilePath -- path to interface + -- file + , Maybe FilePath -- url to html + -- documentation + , Maybe FilePath -- url to hyperlinked + -- source + , Visibility + ) + ] + , Maybe String -- warning about + -- missing documentation + ) +haddockPackageFlags verbosity lbi clbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (componentPackageDeps clbi) + transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of + Left x -> return x + Right inf -> + dieWithException verbosity $ HaddockPackageFlags inf + + haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath + where + mkHtmlPath = fmap expandTemplateVars htmlTemplate + expandTemplateVars tmpl pkg = + fromPathTemplate . substPathTemplate (env pkg) $ tmpl + env pkg = haddockTemplateEnv lbi (packageId pkg) + +haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv +haddockTemplateEnv lbi pkg_id = + (PrefixVar, prefix (installDirTemplates lbi)) + -- We want the legacy unit ID here, because it gives us nice paths + -- (Haddock people don't care about the dependencies) + : initialPathTemplateEnv + pkg_id + (mkLegacyUnitId pkg_id) + (compilerInfo (compiler lbi)) + (hostPlatform lbi) + +-- ------------------------------------------------------------------------------ +-- hscolour support. + +hscolour + :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour = hscolour_setupHooks noBuildHooks + +hscolour_setupHooks + :: BuildHooks + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour_setupHooks setupHooks = + hscolour' setupHooks dieNoVerbosity ForDevelopment + +hscolour' + :: BuildHooks + -> (String -> IO ()) + -- ^ Called when the 'hscolour' exe is not found. + -> HaddockTarget + -> PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' + (BuildHooks{preBuildComponentRules = mbPbcRules}) + onNoHsColour + haddockTarget + pkg_descr + lbi + suffixes + flags = + either (\excep -> onNoHsColour $ exceptionMessage excep) (\(hscolourProg, _, _) -> go hscolourProg) + =<< lookupProgramVersion + verbosity + hscolourProgram + (orLaterVersion (mkVersion [1, 8])) + (withPrograms lbi) + where + common = hscolourCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + + go :: ConfiguredProgram -> IO () + go hscolourProg = do + warn verbosity $ + "the 'cabal hscolour' command is deprecated in favour of 'cabal " + ++ "haddock --hyperlink-source' and will be removed in the next major " + ++ "release." + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ + i $ + hscolourPref haddockTarget distPref pkg_descr + + withAllComponentsInBuildOrder pkg_descr lbi $ \comp clbi -> do + let tgt = TargetInfo clbi comp + runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO () + runPreBuildHooks lbi2 target = + let inputs = + SetupHooks.PreBuildComponentInputs + { SetupHooks.buildingWhat = BuildHscolour flags + , SetupHooks.localBuildInfo = lbi2 + , SetupHooks.targetInfo = target + } + in for_ mbPbcRules $ \pbcRules -> do + (ruleFromId, _mons) <- SetupHooks.computeRules verbosity inputs pbcRules + SetupHooks.executeRules verbosity lbi2 tgt ruleFromId + preBuildComponent runPreBuildHooks verbosity lbi tgt + preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes + let + doExe com = case (compToExe com) of + Just exe -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx (unUnqualComponentName (exeName exe) "src") + runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi + Nothing -> do + warn verbosity "Unsupported component, skipping..." + return () + case comp of + CLib lib -> do + let outputDir = hscolourPref haddockTarget distPref pkg_descr makeRelativePathEx "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi + CFLib flib -> do + let outputDir = + hscolourPref haddockTarget distPref pkg_descr + makeRelativePathEx + ( unUnqualComponentName (foreignLibName flib) + "src" + ) + runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi + CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp + CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp + CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp + + stylesheet = flagToMaybe (hscolourCSS flags) + + runHsColour + :: ConfiguredProgram + -> SymbolicPath Pkg to + -> [(ModuleName.ModuleName, SymbolicPath Pkg to1)] + -> IO () + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True (i outputDir) + + case stylesheet of -- copy the CSS file + Nothing + | programVersion prog >= Just (mkVersion [1, 9]) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-print-css", "-o" ++ u outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (i outputDir "hscolour.css") + + for_ moduleFiles $ \(m, inFile) -> + runProgramCwd + verbosity + mbWorkDir + prog + ["-css", "-anchor", "-o" ++ outFile m, u inFile] + where + outFile m = + i outputDir + intercalate "-" (ModuleName.components m) + <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags + { hscolourCommonFlags = haddockCommonFlags flags + , hscolourCSS = haddockHscolourCss flags + , hscolourExecutables = haddockExecutables flags + , hscolourTestSuites = haddockTestSuites flags + , hscolourBenchmarks = haddockBenchmarks flags + , hscolourForeignLibs = haddockForeignLibs flags + } + +-- ------------------------------------------------------------------------------ +-- Boilerplate Monoid instance. +instance Monoid HaddockArgs where + mempty = gmempty + mappend = (<>) + +instance Semigroup HaddockArgs where + (<>) = gmappend + +instance Monoid Directory where + mempty = Dir "." + mappend = (<>) + +instance Semigroup Directory where + Dir m <> Dir n = Dir $ m n diff --git a/src/Distribution/Simple/HaskellSuite.hs b/src/Distribution/Simple/HaskellSuite.hs deleted file mode 100644 --- a/src/Distribution/Simple/HaskellSuite.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Simple.HaskellSuite where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Data.List.NonEmpty as NE - -import Distribution.Simple.Program -import Distribution.Simple.Compiler -import Distribution.Simple.Utils -import Distribution.Simple.BuildPaths -import Distribution.Verbosity -import Distribution.Version -import Distribution.Pretty -import Distribution.Parsec (simpleParsec) -import Distribution.Package -import Distribution.InstalledPackageInfo hiding (includeDirs) -import Distribution.Simple.PackageIndex as PackageIndex -import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.System (Platform) -import Distribution.Utils.Path -import Language.Haskell.Extension -import Distribution.Simple.Program.Builtin - -configure - :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity mbHcPath hcPkgPath progdb0 = do - - -- We have no idea how a haskell-suite tool is named, so we require at - -- least some information from the user. - hcPath <- - let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)" - in maybe (die' verbosity msg) return mbHcPath - - when (isJust hcPkgPath) $ - warn verbosity "--with-hc-pkg option is ignored for haskell-suite" - - (comp, confdCompiler, progdb1) <- configureCompiler hcPath progdb0 - - -- Update our pkg tool. It uses the same executable as the compiler, but - -- all command start with "pkg" - (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb1 - let progdb2 = - updateProgram - confdPkg - { programLocation = programLocation confdCompiler - , programDefaultArgs = ["pkg"] - } - progdb1 - - return (comp, Nothing, progdb2) - - where - configureCompiler hcPath progdb0' = do - let - haskellSuiteProgram' = - haskellSuiteProgram - { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath } - - -- NB: cannot call requireProgram right away — it'd think that - -- the program is already configured and won't reconfigure it again. - -- Instead, call configureProgram directly first. - progdb1 <- configureProgram verbosity haskellSuiteProgram' progdb0' - (confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1 - - extensions <- getExtensions verbosity confdCompiler - languages <- getLanguages verbosity confdCompiler - (compName, compVersion) <- - getCompilerVersion verbosity confdCompiler - - let - comp = Compiler { - compilerId = CompilerId (HaskellSuite compName) compVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = languages, - compilerExtensions = extensions, - compilerProperties = mempty - } - - return (comp, confdCompiler, progdb2) - -hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version) -hstoolVersion = findProgramVersion "--hspkg-version" id - -numericVersion :: Verbosity -> FilePath -> IO (Maybe Version) -numericVersion = findProgramVersion "--compiler-version" (fromMaybe "" . safeLast . words) - -getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version) -getCompilerVersion verbosity prog = do - output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"] - let - parts = words output - name = concat $ safeInit parts -- there shouldn't be any spaces in the name anyway - versionStr = fromMaybe "" $ safeLast parts - version <- - maybe (die' verbosity "haskell-suite: couldn't determine compiler version") return $ - simpleParsec versionStr - return (name, version) - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)] -getExtensions verbosity prog = do - extStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-extensions"] - return - [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)] -getLanguages verbosity prog = do - langStrs <- - lines `fmap` - rawSystemStdout verbosity (programPath prog) ["--supported-languages"] - return - [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ] - --- Other compilers do some kind of a packagedb stack check here. Not sure --- if we need something like that as well. -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity packagedbs progdb = - liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb -> - do str <- - getDbProgramOutput verbosity haskellSuitePkgProgram progdb - ["dump", packageDbOpt packagedb] - `catchExit` \_ -> die' verbosity $ "pkg dump failed" - case parsePackages str of - Right ok -> return ok - _ -> die' verbosity "failed to parse output of 'pkg dump'" - - where - parsePackages str = - case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of - ([], ok) -> Right [ pkg | (_, pkg) <- ok ] - (msgss, _) -> Left (foldMap NE.toList msgss) - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - -buildLib - :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - -- In future, there should be a mechanism for the compiler to request any - -- number of the above parameters (or their parts) — in particular, - -- pieces of PackageDescription. - -- - -- For now, we only pass those that we know are used. - - let odir = buildDir lbi - bi = libBuildInfo lib - srcDirs = map getSymbolicPath (hsSourceDirs bi) ++ [odir] - dbStack = withPackageDB lbi - language = fromMaybe Haskell98 (defaultLanguage bi) - progdb = withPrograms lbi - pkgid = packageId pkg_descr - - runDbProgram verbosity haskellSuiteProgram progdb $ - [ "compile", "--build-dir", odir ] ++ - concat [ ["-i", d] | d <- srcDirs ] ++ - concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi - ,odir] ++ includeDirs bi ] ++ - [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++ - [ "--package-name", prettyShow pkgid ] ++ - concat [ ["--package-id", prettyShow ipkgid ] - | (ipkgid, _) <- componentPackageDeps clbi ] ++ - ["-G", prettyShow language] ++ - concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++ - cppOptions (libBuildInfo lib) ++ - [ prettyShow modu | modu <- allLibModules lib clbi ] - - - -installLib - :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic libraries - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do - let progdb = withPrograms lbi - runDbProgram verbosity haskellSuitePkgProgram progdb $ - [ "install-library" - , "--build-dir", builtDir - , "--target-dir", targetDir - , "--dynlib-target-dir", dynlibTargetDir - , "--package-id", prettyShow $ packageId pkg - ] ++ map prettyShow (allLibModules lib clbi) - -registerPackage - :: Verbosity - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> IO () -registerPackage verbosity progdb packageDbs installedPkgInfo = do - (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb - - runProgramInvocation verbosity $ - (programInvocation hspkg - ["update", packageDbOpt $ registrationPackageDB packageDbs]) - { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo } - -initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO () -initPackageDB verbosity progdb dbPath = - runDbProgram verbosity haskellSuitePkgProgram progdb - ["init", dbPath] - -packageDbOpt :: PackageDB -> String -packageDbOpt GlobalPackageDB = "--global" -packageDbOpt UserPackageDB = "--user" -packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db diff --git a/src/Distribution/Simple/Hpc.hs b/src/Distribution/Simple/Hpc.hs --- a/src/Distribution/Simple/Hpc.hs +++ b/src/Distribution/Simple/Hpc.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Hpc -- Copyright : Thomas Tuegel 2011 @@ -13,103 +16,99 @@ -- This module provides functions for locating various HPC-related paths and -- a function for adding the necessary options to a PackageDescription to -- build test suites with HPC enabled. - module Distribution.Simple.Hpc - ( Way(..), guessWay - , htmlDir - , mixDir - , tixDir - , tixFilePath - , markupPackage - , markupTest - ) where + ( Way (..) + , guessWay + , htmlDir + , mixDir + , tixDir + , tixFilePath + , HPCMarkupInfo (..) + , markupPackage + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.ModuleName ( main ) -import qualified Distribution.PackageDescription as PD +import Distribution.ModuleName (ModuleName, main) import Distribution.PackageDescription - ( Library(..) - , TestSuite(..) - , testModules - ) + ( TestSuite (..) + , testModules + ) +import qualified Distribution.PackageDescription as PD import Distribution.Pretty -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , interpretSymbolicPathLBI + , mbWorkDirLBI + ) import Distribution.Simple.Program - ( hpcProgram - , requireProgramVersion - ) -import Distribution.Simple.Program.Hpc ( markup, union ) -import Distribution.Simple.Utils ( notice ) -import Distribution.Version ( anyVersion ) -import Distribution.Verbosity ( Verbosity() ) -import System.Directory ( createDirectoryIfMissing, doesFileExist ) -import System.FilePath + ( hpcProgram + , requireProgramVersion + ) +import Distribution.Simple.Program.Hpc (markup, union) +import Distribution.Simple.Utils (notice) +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path +import Distribution.Verbosity (Verbosity ()) +import Distribution.Version (anyVersion) +import System.Directory (createDirectoryIfMissing, doesFileExist) + -- ------------------------------------------------------------------------- -- Haskell Program Coverage -data Way = Vanilla | Prof | Dyn +data Way = Vanilla | Prof | Dyn | ProfDyn deriving (Bounded, Enum, Eq, Read, Show) -hpcDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Directory containing component's HPC .mix files -hpcDir distPref way = distPref "hpc" wayDir +hpcDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Directory containing component's HPC .mix files +hpcDir distPref way = distPref makeRelativePathEx ("hpc" wayDir) where wayDir = case way of Vanilla -> "vanilla" Prof -> "prof" Dyn -> "dyn" + ProfDyn -> "prof_dyn" -mixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .mix files -mixDir distPref way name = hpcDir distPrefBuild way "mix" name - where - -- This is a hack for HPC over test suites, needed to match the directory - -- where HPC saves and reads .mix files when the main library of the same - -- package is being processed, perhaps in a previous cabal run (#5213). - -- E.g., @distPref@ may be - -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@ - -- but the path where library mix files reside has two less components - -- at the end (@t/tests@) and this reduced path needs to be passed to - -- both @hpc@ and @ghc@. For non-default optimization levels, the path - -- suffix is one element longer and the extra path element needs - -- to be preserved. - distPrefElements = splitDirectories distPref - distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of - ["t", _, "noopt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["noopt"] - ["t", _, "opt"] -> - joinPath $ take (length distPrefElements - 3) distPrefElements - ++ ["opt"] - [_, "t", _] -> - joinPath $ take (length distPrefElements - 2) distPrefElements - _ -> distPref +mixDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Mix) + -- ^ Directory containing test suite's .mix files +mixDir distPref way = hpcDir distPref way makeRelativePathEx "mix" -tixDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Directory containing test suite's .tix files -tixDir distPref way name = hpcDir distPref way "tix" name +tixDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Tix) + -- ^ Directory containing test suite's .tix files +tixDir distPref way = hpcDir distPref way makeRelativePathEx "tix" -- | Path to the .tix file containing a test suite's sum statistics. -tixFilePath :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's .tix file -tixFilePath distPref way name = tixDir distPref way name name <.> "tix" +tixFilePath + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> FilePath + -- ^ Component name + -> SymbolicPath Pkg File + -- ^ Path to test suite's .tix file +tixFilePath distPref way name = tixDir distPref way makeRelativePathEx (name <.> "tix") -htmlDir :: FilePath -- ^ \"dist/\" prefix - -> Way - -> FilePath -- ^ Component name - -> FilePath -- ^ Path to test suite's HTML markup directory -htmlDir distPref way name = hpcDir distPref way "html" name +htmlDir + :: SymbolicPath Pkg (Dir Dist) + -- ^ \"dist/\" prefix + -> Way + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path to test suite's HTML markup directory +htmlDir distPref way = hpcDir distPref way makeRelativePathEx "html" -- | Attempt to guess the way the test suites in this package were compiled -- and linked with the library so the correct module interfaces are found. @@ -119,59 +118,72 @@ | withDynExe lbi = Dyn | otherwise = Vanilla --- | Generate the HTML markup for a test suite. -markupTest :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> String -- ^ Library name - -> TestSuite - -> Library - -> IO () -markupTest verbosity lbi distPref libraryName suite library = do - tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' - when tixFileExists $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let htmlDir_ = htmlDir distPref way testName' - markup hpc hpcVer verbosity - (tixFilePath distPref way testName') mixDirs - htmlDir_ - (exposedModules library) - notice verbosity $ "Test coverage report written to " - ++ htmlDir_ "hpc_index" <.> "html" - where - way = guessWay lbi - testName' = unUnqualComponentName $ testName suite - mixDirs = map (mixDir distPref way) [ testName', libraryName ] +-- | Haskell Program Coverage information required to produce a valid HPC +-- report through the `hpc markup` call for the package libraries. +data HPCMarkupInfo = HPCMarkupInfo + { pathsToLibsArtifacts :: [SymbolicPath Pkg (Dir Artifacts)] + -- ^ The paths to the library components whose modules are included in the + -- coverage report + , libsModulesToInclude :: [ModuleName] + -- ^ The modules to include in the coverage report + } --- | Generate the HTML markup for all of a package's test suites. -markupPackage :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^ \"dist/\" prefix - -> PD.PackageDescription - -> [TestSuite] - -> IO () -markupPackage verbosity lbi distPref pkg_descr suites = do - let tixFiles = map (tixFilePath distPref way) testNames - tixFilesExist <- traverse doesFileExist tixFiles - when (and tixFilesExist) $ do - -- behaviour of 'markup' depends on version, so we need *a* version - -- but no particular one - (hpc, hpcVer, _) <- requireProgramVersion verbosity - hpcProgram anyVersion (withPrograms lbi) - let outFile = tixFilePath distPref way libraryName - htmlDir' = htmlDir distPref way libraryName - excluded = concatMap testModules suites ++ [ main ] - createDirectoryIfMissing True $ takeDirectory outFile - union hpc verbosity tixFiles outFile excluded - markup hpc hpcVer verbosity outFile mixDirs htmlDir' included - notice verbosity $ "Package coverage report written to " - ++ htmlDir' "hpc_index.html" +-- | Generate the HTML markup for a package's test suites. +markupPackage + :: Verbosity + -> HPCMarkupInfo + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -- ^ Testsuite \"dist/\" prefix + -> PD.PackageDescription + -> [TestSuite] + -> IO () +markupPackage verbosity HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} lbi testDistPref pkg_descr suites = do + let tixFiles = map (tixFilePath testDistPref way) testNames + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + tixFilesExist <- traverse (doesFileExist . i) tixFiles + when (and tixFilesExist) $ do + -- behaviour of 'markup' depends on version, so we need *a* version + -- but no particular one + (hpc, hpcVer, _) <- + requireProgramVersion + verbosity + hpcProgram + anyVersion + (withPrograms lbi) + let htmlDir' = htmlDir testDistPref way + -- The tix file used to generate the report is either the testsuite's + -- tix file, when there is only one testsuite, or the sum of the tix + -- files of all testsuites in the package, which gets put under pkgName + -- for this component (a bit weird) + -- TODO: cabal-install should pass to Cabal where to put the summed tix + -- and report, and perhaps even the testsuites from other packages in + -- the project which are currently not accounted for in the summed + -- report. + tixFile <- case suites of + -- We call 'markupPackage' once for each testsuite to run individually, + -- to get the coverage report of just the one testsuite + [oneTest] -> do + let testName' = unUnqualComponentName $ testName oneTest + return $ + tixFilePath testDistPref way testName' + -- And call 'markupPackage' once per `test` invocation with all the + -- testsuites to run, which results in multiple tix files being considered + _ -> do + let excluded = concatMap testModules suites ++ [main] + pkgName = prettyShow $ PD.package pkg_descr + summedTixFile = tixFilePath testDistPref way pkgName + createDirectoryIfMissing True $ i $ takeDirectorySymbolicPath summedTixFile + union mbWorkDir hpc verbosity tixFiles summedTixFile excluded + return summedTixFile + + markup mbWorkDir hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude + notice verbosity $ + "Package coverage report written to " + ++ i htmlDir' + "hpc_index.html" where way = guessWay lbi testNames = fmap (unUnqualComponentName . testName) suites - mixDirs = map (mixDir distPref way) $ libraryName : testNames - included = concatMap (exposedModules) $ PD.allLibraries pkg_descr - libraryName = prettyShow $ PD.package pkg_descr + mixDirs = map ((`mixDir` way) . coerceSymbolicPath) pathsToLibsArtifacts diff --git a/src/Distribution/Simple/Install.hs b/src/Distribution/Simple/Install.hs --- a/src/Distribution/Simple/Install.hs +++ b/src/Distribution/Simple/Install.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Install -- Copyright : Isaac Jones 2003-2004 @@ -14,247 +18,355 @@ -- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into -- place based on the prefix argument. It does the generic bits and then calls -- compiler-specific functions to do the rest. - -module Distribution.Simple.Install ( - install, +module Distribution.Simple.Install + ( install + , install_setupHooks + , installFileGlob ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo +import Distribution.CabalSpecVersion (CabalSpecVersion) + +import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib +import Distribution.Types.LocalBuildInfo import Distribution.Types.PackageDescription +import Distribution.Types.TargetInfo import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope import Distribution.Package import Distribution.PackageDescription -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.BuildPaths (haddockPath, haddockPref) +import Distribution.Simple.BuildTarget +import Distribution.Simple.Compiler + ( CompilerFlavor (..) + , compilerFlavor + ) import Distribution.Simple.Glob (matchDirFileGlob) +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Setup.Config +import Distribution.Simple.Setup.Copy + ( CopyFlags (..) + ) +import Distribution.Simple.Setup.Haddock + ( HaddockTarget (ForDevelopment) + ) +import Distribution.Simple.SetupHooks.Internal + ( InstallHooks (..) + ) +import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose - , installDirectoryContents, installOrdinaryFile, isInSearchPath - , die', info, noticeNoWrap, warn ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup - ( CopyFlags(..), fromFlag, HaddockTarget(ForDevelopment) ) -import Distribution.Simple.BuildTarget -import Distribution.Utils.Path (getSymbolicPath) + ( createDirectoryIfMissingVerbose + , dieWithException + , info + , installDirectoryContents + , installOrdinaryFile + , isAbsoluteOnAnyPlatform + , isInSearchPath + , noticeNoWrap + , warn + ) +import Distribution.Utils.Path -import qualified Distribution.Simple.GHC as GHC +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Simple.Errors +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Simple.Setup.Common +import qualified Distribution.Simple.UHC as UHC import System.Directory - ( doesDirectoryExist, doesFileExist ) + ( doesDirectoryExist + , doesFileExist + ) import System.FilePath - ( takeFileName, takeDirectory, (), isRelative ) + ( takeDirectory + , takeFileName + ) -import Distribution.Verbosity import Distribution.Pretty - ( prettyShow ) + ( prettyShow + ) +import Distribution.Verbosity --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. +-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. -- --- This does NOT register libraries, you should call 'register' --- to do that. +-- This does NOT register libraries, you should call 'register' +-- to do that. +install + :: PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () +install = install_setupHooks SetupHooks.noInstallHooks -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () -install pkg_descr lbi flags = do - checkHasLibsOrExes - targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags) +install_setupHooks + :: InstallHooks + -> PackageDescription + -- ^ information from the .cabal file + -> LocalBuildInfo + -- ^ information from the configure step + -> CopyFlags + -- ^ flags sent to copy or install + -> IO () +install_setupHooks + (InstallHooks{installComponentHook}) + pkg_descr + lbi + flags = do + checkHasLibsOrExes + targets <- readTargetInfos verbosity pkg_descr lbi (copyTargets flags) - copyPackage verbosity pkg_descr lbi distPref copydest + copyPackage verbosity pkg_descr lbi distPref copydest - -- It's not necessary to do these in build-order, but it's harmless - withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> - let comp = targetComponent target - clbi = targetCLBI target - in copyComponent verbosity pkg_descr lbi comp clbi copydest - where - distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) + -- It's not necessary to do these in build-order, but it's harmless + withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target -> do + let comp = targetComponent target + clbi = targetCLBI target + copyComponent verbosity pkg_descr lbi comp clbi copydest + for_ installComponentHook $ \instAction -> + let inputs = + SetupHooks.InstallComponentInputs + { copyFlags = flags + , localBuildInfo = lbi + , targetInfo = target + } + in instAction inputs + where + common = copyCommonFlags flags + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + copydest = fromFlag (copyDest flags) - checkHasLibsOrExes = - unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ - die' verbosity "No executables and no library found. Nothing to do." + checkHasLibsOrExes = + unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $ + warn verbosity "No executables and no library found. Nothing to do." -- | Copy package global files. -copyPackage :: Verbosity -> PackageDescription - -> LocalBuildInfo -> FilePath -> CopyDest -> IO () +copyPackage + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> SymbolicPath Pkg (Dir Dist) + -> CopyDest + -> IO () copyPackage verbosity pkg_descr lbi distPref copydest = do - let -- This is a bit of a hack, to handle files which are not - -- per-component (data files and Haddock files.) - InstallDirs { - datadir = dataPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref + let + -- This is a bit of a hack, to handle files which are not + -- per-component (data files and Haddock files.) + InstallDirs + { datadir = dataPref + , docdir = docPref + , htmldir = htmlPref + , haddockdir = interfacePref } = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path -- Install (package-global) data files - installDataFiles verbosity pkg_descr dataPref + installDataFiles verbosity mbWorkDir pkg_descr $ makeSymbolicPath dataPref -- Install (package-global) Haddock files -- TODO: these should be done per-library - docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr - info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++ - " does exist: " ++ show docExists) + docExists <- doesDirectoryExist $ i $ haddockPref ForDevelopment distPref pkg_descr + info + verbosity + ( "directory " + ++ getSymbolicPath (haddockPref ForDevelopment distPref pkg_descr) + ++ " does exist: " + ++ show docExists + ) -- TODO: this is a bit questionable, Haddock files really should -- be per library (when there are convenience libraries.) when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref ForDevelopment distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents + verbosity + (i $ haddockPref ForDevelopment distPref pkg_descr) + htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = + haddockPref ForDevelopment distPref pkg_descr + makeRelativePathEx (haddockPath pkg_descr) + haddockInterfaceFileDest = interfacePref haddockPath pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist $ i haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile + verbosity + (i haddockInterfaceFileSrc) + haddockInterfaceFileDest let lfiles = licenseFiles pkg_descr unless (null lfiles) $ do createDirectoryIfMissingVerbose verbosity True docPref - for_ lfiles $ \lfile' -> do - let lfile :: FilePath - lfile = getSymbolicPath lfile' - installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + for_ lfiles $ \lfile -> do + installOrdinaryFile + verbosity + (i lfile) + (docPref takeFileName (getSymbolicPath lfile)) -- | Copy files associated with a component. -copyComponent :: Verbosity -> PackageDescription - -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo - -> CopyDest - -> IO () +copyComponent + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Component + -> ComponentLocalBuildInfo + -> CopyDest + -> IO () copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do - let InstallDirs{ - libdir = libPref, - dynlibdir = dynlibPref, - includedir = incPref - } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - case libName lib of - LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) - LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) + let InstallDirs + { libdir = libPref + , dynlibdir = dynlibPref + , includedir = incPref + } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + case libName lib of + LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref) + LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref) - case compilerFlavor (compiler lbi) of - GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - HaskellSuite _ -> HaskellSuite.installLib - verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref + case compilerFlavor (compiler lbi) of + GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi + _ -> + dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do - let InstallDirs{ - flibdir = flibPref, - includedir = incPref - } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - buildPref = componentBuildDir lbi clbi - - noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) - installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + let InstallDirs + { flibdir = flibPref + , includedir = incPref + } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + buildPref = interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi - case compilerFlavor (compiler lbi) of - GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib - GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib - _ -> die' verbosity $ "installing foreign lib with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref) + installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref + case compilerFlavor (compiler lbi) of + GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib + GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib + _ -> dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do - let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest - -- the installers know how to find the actual location of the - -- binaries - buildPref = buildDir lbi - uid = componentUnitId clbi - pkgid = packageId pkg_descr - binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs - | otherwise = bindir installDirs - progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) - progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) - progFix = (progPrefixPref, progSuffixPref) - noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe) - ++ " in " ++ binPref) - inPath <- isInSearchPath binPref - when (not inPath) $ - warn verbosity ("The directory " ++ binPref - ++ " is not in the system search path.") - case compilerFlavor (compiler lbi) of - GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe - UHC -> return () - HaskellSuite {} -> return () - _ -> die' verbosity $ "installing with " - ++ prettyShow (compilerFlavor (compiler lbi)) - ++ " is not implemented" + let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest + -- the installers know how to find the actual location of the + -- binaries + buildPref = interpretSymbolicPathLBI lbi $ buildDir lbi + uid = componentUnitId clbi + pkgid = packageId pkg_descr + binPref + | ExecutablePrivate <- exeScope exe = libexecdir installDirs + | otherwise = bindir installDirs + progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi) + progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi) + progFix = (progPrefixPref, progSuffixPref) + noticeNoWrap + verbosity + ( "Installing executable " + ++ prettyShow (exeName exe) + ++ " in " + ++ binPref + ) + inPath <- isInSearchPath binPref + when (not inPath) $ + warn + verbosity + ( "The directory " + ++ binPref + ++ " is not in the system search path." + ) + case compilerFlavor (compiler lbi) of + GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe + UHC -> return () + _ -> + dieWithException verbosity $ CompilerNotInstalled (compilerFlavor (compiler lbi)) -- Nothing to do for benchmark/testsuite copyComponent _ _ _ (CBench _) _ _ = return () copyComponent _ _ _ (CTest _) _ _ = return () -- | Install the files listed in data-files --- -installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installDataFiles verbosity pkg_descr destDataDir = - flip traverse_ (dataFiles pkg_descr) $ \ glob -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir = if null srcDataDirRaw - then "." - else srcDataDirRaw - files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob - for_ files $ \ file' -> do - let src = srcDataDir file' - dst = destDataDir file' - createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) - installOrdinaryFile verbosity src dst +installDataFiles + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDescription + -> SymbolicPath Pkg (Dir DataDir) + -> IO () +installDataFiles verbosity mbWorkDir pkg_descr destDataDir = + traverse_ + (installFileGlob verbosity (specVersion pkg_descr) mbWorkDir (srcDataDir, destDataDir)) + (dataFiles pkg_descr) + where + srcDataDirRaw = getSymbolicPath $ dataDir pkg_descr + srcDataDir :: Maybe (SymbolicPath CWD (Dir DataDir)) + srcDataDir + | null srcDataDirRaw = + Nothing + | isAbsoluteOnAnyPlatform srcDataDirRaw = + Just $ makeSymbolicPath srcDataDirRaw + | otherwise = + Just $ fromMaybe sameDirectory mbWorkDir makeRelativePathEx srcDataDirRaw +-- | Install the files specified by the given glob pattern. +installFileGlob + :: Verbosity + -> CabalSpecVersion + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> (Maybe (SymbolicPath CWD (Dir DataDir)), SymbolicPath Pkg (Dir DataDir)) + -- ^ @(src_dir, dest_dir)@ + -> RelativePath DataDir File + -- ^ file glob pattern + -> IO () +installFileGlob verbosity spec_version mbWorkDir (srcDir, destDir) glob = do + files <- matchDirFileGlob verbosity spec_version srcDir glob + for_ files $ \file' -> do + let src = getSymbolicPath (fromMaybe sameDirectory srcDir file') + dst = interpretSymbolicPath mbWorkDir (destDir file') + createDirectoryIfMissingVerbose verbosity True (takeDirectory dst) + installOrdinaryFile verbosity src dst + -- | Install the files listed in install-includes for a library --- installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do - let relincdirs = "." : filter isRelative (includeDirs libBi) - incdirs = [ baseDir lbi dir | dir <- relincdirs ] - ++ [ buildPref dir | dir <- relincdirs ] - incs <- traverse (findInc incdirs) (installIncludes libBi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] + let relincdirs = sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs libBi) + incdirs = + [ root getSymbolicPath dir + | -- NB: both baseDir and buildPref are already interpreted, + -- so we don't need to interpret these paths in the call to findInc. + dir <- relincdirs + , root <- [baseDir lbi, buildPref] + ] + incs <- traverse (findInc incdirs . getSymbolicPath) (installIncludes libBi) + sequence_ + [ do + createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile + ] where - baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi') - findInc [] file = die' verbosity ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file + baseDir lbi' = packageRoot $ configCommonFlags $ configFlags lbi' + findInc [] file = dieWithException verbosity $ CantFindIncludeFile file + findInc (dir : dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file diff --git a/src/Distribution/Simple/InstallDirs.hs b/src/Distribution/Simple/InstallDirs.hs --- a/src/Distribution/Simple/InstallDirs.hs +++ b/src/Distribution/Simple/InstallDirs.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 @@ -22,48 +22,49 @@ -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates. - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - defaultInstallDirs', - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - PathTemplateEnv, - toPathTemplate, - fromPathTemplate, - combinePathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - abiTemplateEnv, - installDirsTemplateEnv, +module Distribution.Simple.InstallDirs + ( InstallDirs (..) + , InstallDirTemplates + , defaultInstallDirs + , defaultInstallDirs' + , combineInstallDirs + , absoluteInstallDirs + , CopyDest (..) + , prefixRelativeInstallDirs + , substituteInstallDirTemplates + , PathTemplate + , PathTemplateVariable (..) + , PathTemplateEnv + , toPathTemplate + , fromPathTemplate + , combinePathTemplate + , substPathTemplate + , initialPathTemplateEnv + , platformTemplateEnv + , compilerTemplateEnv + , packageTemplateEnv + , abiTemplateEnv + , installDirsTemplateEnv ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Compat.Environment (lookupEnv) -import Distribution.Pretty -import Distribution.Package -import Distribution.System import Distribution.Compiler +import Distribution.Package +import Distribution.Pretty import Distribution.Simple.InstallDirs.Internal +import Distribution.System import System.Directory (getAppUserDataDirectory) import System.FilePath - ( (), isPathSeparator - , pathSeparator, dropDrive - , takeDirectory ) + ( dropDrive + , isPathSeparator + , pathSeparator + , takeDirectory + , () + ) #ifdef mingw32_HOST_OS import qualified Prelude @@ -74,32 +75,32 @@ -- --------------------------------------------------------------------------- -- Installation directories - -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - flibdir :: dir, -- ^ foreign libraries - libexecdir :: dir, - libexecsubdir:: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir, - sysconfdir :: dir - } deriving (Eq, Read, Show, Functor, Generic, Typeable) +data InstallDirs dir = InstallDirs + { prefix :: dir + , bindir :: dir + , libdir :: dir + , libsubdir :: dir + , dynlibdir :: dir + , flibdir :: dir + -- ^ foreign libraries + , libexecdir :: dir + , libexecsubdir :: dir + , includedir :: dir + , datadir :: dir + , datasubdir :: dir + , docdir :: dir + , mandir :: dir + , htmldir :: dir + , haddockdir :: dir + , sysconfdir :: dir + } + deriving (Eq, Read, Show, Functor, Generic) instance Binary dir => Binary (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) @@ -111,38 +112,41 @@ instance Semigroup dir => Semigroup (InstallDirs dir) where (<>) = gmappend -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - flibdir = flibdir a `combine` flibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - libexecsubdir= libexecsubdir a `combine` libexecsubdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b, - sysconfdir = sysconfdir a `combine` sysconfdir b - } +combineInstallDirs + :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = + InstallDirs + { prefix = prefix a `combine` prefix b + , bindir = bindir a `combine` bindir b + , libdir = libdir a `combine` libdir b + , libsubdir = libsubdir a `combine` libsubdir b + , dynlibdir = dynlibdir a `combine` dynlibdir b + , flibdir = flibdir a `combine` flibdir b + , libexecdir = libexecdir a `combine` libexecdir b + , libexecsubdir = libexecsubdir a `combine` libexecsubdir b + , includedir = includedir a `combine` includedir b + , datadir = datadir a `combine` datadir b + , datasubdir = datasubdir a `combine` datasubdir b + , docdir = docdir a `combine` docdir b + , mandir = mandir a `combine` mandir b + , htmldir = htmldir a `combine` htmldir b + , haddockdir = haddockdir a `combine` haddockdir b + , sysconfdir = sysconfdir a `combine` sysconfdir b + } appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - libexecdir = libexecdir dirs `append` libexecsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - libexecsubdir = error "internal error InstallDirs.libexecsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } +appendSubdirs append dirs = + dirs + { libdir = libdir dirs `append` libsubdir dirs + , libexecdir = libexecdir dirs `append` libexecsubdir dirs + , datadir = datadir dirs `append` datasubdir dirs + , libsubdir = error "internal error InstallDirs.libsubdir" + , libexecsubdir = error "internal error InstallDirs.libexecsubdir" + , datasubdir = error "internal error InstallDirs.datasubdir" + } -- | The installation directories in terms of 'PathTemplate's that contain -- variables. @@ -165,7 +169,6 @@ -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. --- type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- @@ -174,56 +177,77 @@ defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs = defaultInstallDirs' False -defaultInstallDirs' :: Bool {- use external internal deps -} - -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs' + :: Bool {- use external internal deps -} + -> CompilerFlavor + -> Bool + -> Bool + -> IO InstallDirTemplates defaultInstallDirs' True comp userInstall hasLibs = do dflt <- defaultInstallDirs' False comp userInstall hasLibs -- Be a bit more hermetic about per-component installs - return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", - docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" - } + return + dflt + { datasubdir = toPathTemplate $ "$abi" "$libname" + , docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" + } defaultInstallDirs' False comp userInstall _hasLibs = do installPrefix <- - if userInstall + if userInstall then do mDir <- lookupEnv "CABAL_DIR" case mDir of Nothing -> getAppUserDataDirectory "cabal" Just dir -> return dir else case buildOS of - Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir - return (windowsProgramFilesDir "Haskell") - _ -> return "/usr/local" + Windows -> do + windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + Haiku -> return "/boot/system/non-packaged" + _ -> return "/usr/local" installLibDir <- - case buildOS of + case buildOS of Windows -> return "$prefix" - _ -> return ("$prefix" "lib") - return $ fmap toPathTemplate $ InstallDirs { - prefix = installPrefix, - bindir = "$prefix" "bin", - libdir = installLibDir, - libsubdir = case comp of - UHC -> "$pkgid" - _other -> "$abi" "$libname", - dynlibdir = "$libdir" case comp of - UHC -> "$pkgid" - _other -> "$abi", - libexecsubdir= "$abi" "$pkgid", - flibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$libname" - _other -> "$prefix" "libexec", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$abi" "$pkgid", - docdir = "$datadir" "doc" "$abi" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir", - sysconfdir = "$prefix" "etc" - } + _ -> return ("$prefix" "lib") + return $ + fmap toPathTemplate $ + InstallDirs + { prefix = installPrefix + , bindir = "$prefix" "bin" + , libdir = installLibDir + , libsubdir = case comp of + UHC -> "$pkgid" + _other -> "$abi" "$libname" + , dynlibdir = + "$libdir" case comp of + UHC -> "$pkgid" + _other -> "$abi" + , libexecsubdir = "$abi" "$pkgid" + , flibdir = "$libdir" + , libexecdir = case buildOS of + Windows -> "$prefix" "$libname" + Haiku -> "$libdir" + _other -> "$prefix" "libexec" + , includedir = case buildOS of + Haiku -> "$prefix" "develop" "headers" + _other -> "$libdir" "$libsubdir" "include" + , datadir = case buildOS of + Windows -> "$prefix" + Haiku -> "$prefix" "data" + _other -> "$prefix" "share" + , datasubdir = "$abi" "$pkgid" + , docdir = case buildOS of + Haiku -> "$prefix" "documentation" + _other -> "$datadir" "doc" "$abi" "$pkgid" + , mandir = case buildOS of + Haiku -> "$docdir" "man" + _other -> "$datadir" "man" + , htmldir = "$docdir" "html" + , haddockdir = "$htmldir" + , sysconfdir = case buildOS of + Haiku -> "boot" "system" "settings" + _other -> "$prefix" "etc" + } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative @@ -239,102 +263,113 @@ -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates + :: PathTemplateEnv + -> InstallDirTemplates + -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs' where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - libexecsubdir = subst libexecsubdir [], - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]), - sysconfdir = subst sysconfdir prefixBinLibVars - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) + dirs' = + InstallDirs + { -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [] + , bindir = subst bindir [prefixVar] + , libdir = subst libdir [prefixVar, bindirVar] + , libsubdir = subst libsubdir [] + , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar] + , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar] + , libexecdir = subst libexecdir prefixBinLibVars + , libexecsubdir = subst libexecsubdir [] + , includedir = subst includedir prefixBinLibVars + , datadir = subst datadir prefixBinLibVars + , datasubdir = subst datasubdir [] + , docdir = subst docdir prefixBinLibDataVars + , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]) + , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]) + , haddockdir = + subst + haddockdir + ( prefixBinLibDataVars + ++ [docdirVar, htmldirVar] + ) + , sysconfdir = subst sysconfdir prefixBinLibVars + } + subst dir env' = substPathTemplate (env' ++ env) (dir dirs) - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path. -absoluteInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> CopyDest - -> Platform - -> InstallDirs PathTemplate - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> CopyDest + -> Platform + -> InstallDirs PathTemplate + -> InstallDirs FilePath absoluteInstallDirs pkgId libname compilerId copydest platform dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs + ( case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) + _ -> id + ) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId libname compilerId platform substPrefix pre root path | pre `isPrefixOf` path = root ++ drop (length pre) path - | otherwise = path - + | otherwise = path --- |The location prefix for the /copy/ command. +-- | The location prefix for the /copy/ command. data CopyDest = NoCopyDest | CopyTo FilePath - | CopyToDb FilePath - -- ^ when using the ${pkgroot} as prefix. The CopyToDb will - -- adjust the paths to be relative to the provided package - -- database when copying / installing. + | -- | when using the ${pkgroot} as prefix. The CopyToDb will + -- adjust the paths to be relative to the provided package + -- database when copying / installing. + CopyToDb FilePath deriving (Eq, Show, Generic) +-- TODO: are these paths absolute or relative? Relative to what? + instance Binary CopyDest +instance Structured CopyDest -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId libname compilerId platform dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map + fmap relative + . appendSubdirs combinePathTemplate + $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } + env + dirs + { prefix = PathTemplate [Variable PrefixVar] + } where env = initialPathTemplateEnv pkgId libname compilerId platform @@ -342,19 +377,18 @@ -- path by stripping off $prefix/ or $prefix relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : Ordinary (s : rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing + relative' _ = Nothing -- --------------------------------------------------------------------------- -- Path templates -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. --- newtype PathTemplate = PathTemplate [PathComponent] - deriving (Eq, Ord, Generic, Typeable) + deriving (Eq, Ord, Generic) instance Binary PathTemplate instance Structured PathTemplate @@ -362,15 +396,14 @@ type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- toPathTemplate :: FilePath -> PathTemplate -toPathTemplate fp = PathTemplate +toPathTemplate fp = + PathTemplate . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) . readMaybe -- TODO: eradicateNoParse $ fp -- | Convert back to a path, any remaining vars are included --- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template @@ -380,71 +413,80 @@ substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] + PathTemplate (concatMap subst template) + where + subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] -- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier - -> UnitId - -> CompilerInfo - -> Platform - -> PathTemplateEnv +initialPathTemplateEnv + :: PackageIdentifier + -> UnitId + -> CompilerInfo + -> Platform + -> PathTemplateEnv initialPathTemplateEnv pkgId libname compiler platform = - packageTemplateEnv pkgId libname - ++ compilerTemplateEnv compiler - ++ platformTemplateEnv platform - ++ abiTemplateEnv compiler platform + packageTemplateEnv pkgId libname + ++ compilerTemplateEnv compiler + ++ platformTemplateEnv platform + ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId uid = - [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) - -- Invariant: uid is actually a HashedUnitId. Hard to enforce because - -- it's an API change. - ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) - ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) + [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) + , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) + , -- Invariant: uid is actually a HashedUnitId. Hard to enforce because + -- it's an API change. + (LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) + , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) ] compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler = - [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) + [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) ] platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ prettyShow os]) - ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) + [ (OSVar, PathTemplate [Ordinary $ prettyShow os]) + , (ArchVar, PathTemplate [Ordinary $ prettyShow arch]) ] abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) = - [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ - '-':prettyShow (compilerInfoId compiler) ++ - case compilerInfoAbiTag compiler of - NoAbiTag -> "" - AbiTag tag -> '-':tag]) - ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) + [ + ( AbiVar + , PathTemplate + [ Ordinary $ + prettyShow arch + ++ '-' + : prettyShow os + ++ '-' + : prettyShow (compilerInfoId compiler) + ++ case compilerInfoAbiTag compiler of + NoAbiTag -> "" + AbiTag tag -> '-' : tag + ] + ) + , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) ] installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DynlibdirVar, dynlibdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) + [ (PrefixVar, prefix dirs) + , (BindirVar, bindir dirs) + , (LibdirVar, libdir dirs) + , (LibsubdirVar, libsubdir dirs) + , (DynlibdirVar, dynlibdir dirs) + , (DatadirVar, datadir dirs) + , (DatasubdirVar, datasubdir dirs) + , (DocdirVar, docdir dirs) + , (HtmldirVar, htmldir dirs) ] - -- --------------------------------------------------------------------------- -- Parsing and showing path templates: @@ -458,13 +500,16 @@ show (PathTemplate template) = show (show template) instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] + readsPrec p s = + [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path + ] -- --------------------------------------------------------------------------- -- Internal utilities +{- FOURMOLU_DISABLE -} getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #ifdef mingw32_HOST_OS @@ -473,6 +518,7 @@ let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) +{- FOURMOLU_ENABLE -} #ifdef mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) @@ -490,7 +536,8 @@ -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b -#ifdef x86_64_HOST_ARCH +{- FOURMOLU_DISABLE -} +#if defined(x86_64_HOST_ARCH) || defined(aarch64_HOST_ARCH) #define CALLCONV ccall #else #define CALLCONV stdcall @@ -504,3 +551,4 @@ -> CWString -> Prelude.IO CInt #endif +{- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Simple/InstallDirs/Internal.hs b/src/Distribution/Simple/InstallDirs/Internal.hs --- a/src/Distribution/Simple/InstallDirs/Internal.hs +++ b/src/Distribution/Simple/InstallDirs/Internal.hs @@ -1,127 +1,159 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Simple.InstallDirs.Internal - ( PathComponent(..) - , PathTemplateVariable(..) + ( PathComponent (..) + , PathTemplateVariable (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving (Eq, Ord, Generic, Typeable) +data PathComponent + = Ordinary FilePath + | Variable PathTemplateVariable + deriving (Eq, Ord, Generic) instance Binary PathComponent instance Structured PathComponent -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DynlibdirVar -- ^ The @$dynlibdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | LibNameVar -- ^ The @$libname@ path variable - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - | OSVar -- ^ The operating system name, eg @windows@ or @linux@ - | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@ - | AbiVar -- ^ The compiler's ABI identifier, - --- $arch-$os-$compiler-$abitag - | AbiTagVar -- ^ The optional ABI tag for the compiler - | ExecutableNameVar -- ^ The executable name; used in shell wrappers - | TestSuiteNameVar -- ^ The name of the test suite being run - | TestSuiteResultVar -- ^ The result of the test suite being run, eg - -- @pass@, @fail@, or @error@. - | BenchmarkNameVar -- ^ The name of the benchmark being run - deriving (Eq, Ord, Generic, Typeable) +data PathTemplateVariable + = -- | The @$prefix@ path variable + PrefixVar + | -- | The @$bindir@ path variable + BindirVar + | -- | The @$libdir@ path variable + LibdirVar + | -- | The @$libsubdir@ path variable + LibsubdirVar + | -- | The @$dynlibdir@ path variable + DynlibdirVar + | -- | The @$datadir@ path variable + DatadirVar + | -- | The @$datasubdir@ path variable + DatasubdirVar + | -- | The @$docdir@ path variable + DocdirVar + | -- | The @$htmldir@ path variable + HtmldirVar + | -- | The @$pkg@ package name path variable + PkgNameVar + | -- | The @$version@ package version path variable + PkgVerVar + | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@ + PkgIdVar + | -- | The @$libname@ path variable + LibNameVar + | -- | The compiler name and version, eg @ghc-6.6.1@ + CompilerVar + | -- | The operating system name, eg @windows@ or @linux@ + OSVar + | -- | The CPU architecture name, eg @i386@ or @x86_64@ + ArchVar + | -- | The compiler's ABI identifier, + AbiVar + | --- $arch-$os-$compiler-$abitag + -- | The optional ABI tag for the compiler + AbiTagVar + | -- | The executable name; used in shell wrappers + ExecutableNameVar + | -- | The name of the test suite being run + TestSuiteNameVar + | -- | The result of the test suite being run, eg + -- @pass@, @fail@, or @error@. + TestSuiteResultVar + | -- | The name of the benchmark being run + BenchmarkNameVar + deriving (Eq, Ord, Generic) + instance Binary PathTemplateVariable instance Structured PathTemplateVariable instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show LibNameVar = "libname" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DynlibdirVar = "dynlibdir" - show DatadirVar = "datadir" + show PrefixVar = "prefix" + show LibNameVar = "libname" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DynlibdirVar = "dynlibdir" + show DatadirVar = "datadir" show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show AbiTagVar = "abitag" - show AbiVar = "abi" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show AbiTagVar = "abitag" + show AbiVar = "abi" show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" + show TestSuiteNameVar = "test-suite" show TestSuiteResultVar = "result" - show BenchmarkNameVar = "benchmark" + show BenchmarkNameVar = "benchmark" instance Read PathTemplateVariable where readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - -- NB: order matters! Longer strings first - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("dynlibdir", DynlibdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("libname", LibNameVar) - ,("pkgkey", LibNameVar) -- backwards compatibility - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("abitag", AbiTagVar) - ,("abi", AbiVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar) - ,("benchmark", BenchmarkNameVar)] + take + 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s + ] + where + -- NB: order matters! Longer strings first + vars = + [ ("prefix", PrefixVar) + , ("bindir", BindirVar) + , ("libdir", LibdirVar) + , ("libsubdir", LibsubdirVar) + , ("dynlibdir", DynlibdirVar) + , ("datadir", DatadirVar) + , ("datasubdir", DatasubdirVar) + , ("docdir", DocdirVar) + , ("htmldir", HtmldirVar) + , ("pkgid", PkgIdVar) + , ("libname", LibNameVar) + , ("pkgkey", LibNameVar) -- backwards compatibility + , ("pkg", PkgNameVar) + , ("version", PkgVerVar) + , ("compiler", CompilerVar) + , ("os", OSVar) + , ("arch", ArchVar) + , ("abitag", AbiTagVar) + , ("abi", AbiVar) + , ("executablename", ExecutableNameVar) + , ("test-suite", TestSuiteNameVar) + , ("result", TestSuiteResultVar) + , ("benchmark", BenchmarkNameVar) + ] instance Show PathComponent where show (Ordinary path) = path - show (Variable var) = '$':show var + show (Variable var) = '$' : show var showList = foldr (\x -> (shows x .)) id instance Read PathComponent where -- for some reason we collapse multiple $ symbols here readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] + where + lex0 [] = [] + lex0 ('$' : '$' : s') = lex0 ('$' : s') + lex0 ('$' : s') = case [ (Variable var, s'') + | (var, s'') <- reads s' + ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s) + lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)] + lex1 acc (c : s) = lex1 (c : acc) s + readList [] = [([], "")] + readList s = + [ (component : components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' + ] diff --git a/src/Distribution/Simple/LocalBuildInfo.hs b/src/Distribution/Simple/LocalBuildInfo.hs --- a/src/Distribution/Simple/LocalBuildInfo.hs +++ b/src/Distribution/Simple/LocalBuildInfo.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.LocalBuildInfo -- Copyright : Isaac Jones 2003-2004 @@ -18,166 +20,231 @@ -- programs, the package database to use and a bunch of miscellaneous configure -- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets -- passed in to very many subsequent build actions. - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - localComponentId, - localUnitId, - localCompatPackageKey, +module Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo (..) + , localComponentId + , localUnitId + , localCompatPackageKey - -- * Buildable package components - Component(..), - ComponentName(..), - LibraryName(..), - defaultLibName, - showComponentName, - componentNameString, - ComponentLocalBuildInfo(..), - componentBuildDir, - foldComponent, - componentName, - componentBuildInfo, - componentBuildable, - pkgComponents, - pkgBuildableComponents, - lookupComponent, - getComponent, - allComponentsInBuildOrder, - depLibraryPaths, - allLibModules, + -- * Convenience accessors + , buildDir + , packageRoot + , progPrefix + , progSuffix + , interpretSymbolicPathLBI + , mbWorkDirLBI + , absoluteWorkingDirLBI + , buildWays - withAllComponentsInBuildOrder, - withLibLBI, - withExeLBI, - withBenchLBI, - withTestLBI, - enabledTestLBIs, - enabledBenchLBIs, + -- * Buildable package components + , Component (..) + , ComponentName (..) + , LibraryName (..) + , defaultLibName + , showComponentName + , componentNameString + , ComponentLocalBuildInfo (..) + , componentBuildDir + , foldComponent + , componentName + , componentBuildInfo + , componentBuildable + , pkgComponents + , pkgBuildableComponents + , lookupComponent + , getComponent + , allComponentsInBuildOrder + , depLibraryPaths + , allLibModules + , withAllComponentsInBuildOrder + , withLibLBI + , withExeLBI + , withBenchLBI + , withTestLBI + , enabledTestLBIs + , enabledBenchLBIs - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - absoluteInstallCommandDirs, - absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs, - substPathTemplate, + -- * Installation directories + , module Distribution.Simple.InstallDirs + , absoluteInstallDirs + , prefixRelativeInstallDirs + , absoluteInstallCommandDirs + , absoluteComponentInstallDirs + , prefixRelativeComponentInstallDirs + , substPathTemplate ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Types.Component -import Distribution.Types.PackageId -import Distribution.Types.UnitId -import Distribution.Types.ComponentName -import Distribution.Types.UnqualComponentName -import Distribution.Types.PackageDescription import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.ComponentName import Distribution.Types.LocalBuildInfo +import Distribution.Types.PackageDescription +import Distribution.Types.PackageId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId +import Distribution.Types.UnqualComponentName -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.PackageDescription +import qualified Distribution.Compat.Graph as Graph import qualified Distribution.InstalledPackageInfo as Installed -import Distribution.Package import Distribution.ModuleName +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Simple.PackageIndex +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config import Distribution.Simple.Utils -import Distribution.Pretty -import qualified Distribution.Compat.Graph as Graph +import Distribution.Utils.Path import Data.List (stripPrefix) -import System.FilePath - -import System.Directory (doesDirectoryExist, canonicalizePath) +import qualified System.Directory as Directory + ( canonicalizePath + , doesDirectoryExist + ) -- ----------------------------------------------------------------------------- -- Configuration information of buildable components -componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath +componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Build) -- For now, we assume that libraries/executables/test-suites/benchmarks -- are only ever built once. With Backpack, we need a special case for -- libraries so that we can handle building them multiple times. -componentBuildDir lbi clbi - = buildDir lbi - case componentLocalName clbi of - CLibName LMainLibName -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then "" - else prettyShow (componentUnitId clbi) - CLibName (LSubLibName s) -> - if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) - then unUnqualComponentName s - else prettyShow (componentUnitId clbi) - CFLibName s -> unUnqualComponentName s - CExeName s -> unUnqualComponentName s - CTestName s -> unUnqualComponentName s - CBenchName s -> unUnqualComponentName s +componentBuildDir lbi clbi = + (buildDir lbi ) $ + makeRelativePathEx $ + case componentLocalName clbi of + CLibName LMainLibName -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then "" + else prettyShow (componentUnitId clbi) + CLibName (LSubLibName s) -> + if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi) + then unUnqualComponentName s + else prettyShow (componentUnitId clbi) + CFLibName s -> unUnqualComponentName s + CExeName s -> unUnqualComponentName s + CTestName s -> unUnqualComponentName s + CBenchName s -> unUnqualComponentName s +-- | Interpret a symbolic path with respect to the working directory +-- stored in 'LocalBuildInfo'. +-- +-- Use this before directly interacting with the file system. +-- +-- NB: when invoking external programs (such as @GHC@), it is preferable to set +-- the working directory of the process rather than calling this function, as +-- this function will turn relative paths into absolute paths if the working +-- directory is an absolute path. This can degrade error messages, or worse, +-- break the behaviour entirely (because the program might expect certain paths +-- to be relative). +-- +-- See Note [Symbolic paths] in Distribution.Utils.Path +interpretSymbolicPathLBI :: LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath +interpretSymbolicPathLBI lbi = + interpretSymbolicPath (mbWorkDirLBI lbi) + +-- | Retrieve an optional working directory from 'LocalBuildInfo'. +mbWorkDirLBI :: LocalBuildInfo -> Maybe (SymbolicPath CWD (Dir Pkg)) +mbWorkDirLBI = + flagToMaybe . setupWorkingDir . configCommonFlags . configFlags + +-- | Absolute path to the current working directory. +absoluteWorkingDirLBI :: LocalBuildInfo -> IO (AbsolutePath (Dir Pkg)) +absoluteWorkingDirLBI lbi = absoluteWorkingDir (mbWorkDirLBI lbi) + -- | Perform the action on each enabled 'library' in the package -- description with the 'ComponentLocalBuildInfo'. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI + :: PackageDescription + -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) + -> IO () withLibLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CLib lib -> f lib (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CLib lib -> f lib (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Executable' in the package -- description. Extended version of 'withExe' that also gives corresponding -- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI + :: PackageDescription + -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) + -> IO () withExeLBI pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - case targetComponent target of - CExe exe -> f exe (targetCLBI target) - _ -> return () + withAllTargetsInBuildOrder' pkg lbi $ \target -> + case targetComponent target of + CExe exe -> f exe (targetCLBI target) + _ -> return () -- | Perform the action on each enabled 'Benchmark' in the package -- description. -withBenchLBI :: PackageDescription -> LocalBuildInfo - -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO () +withBenchLBI + :: PackageDescription + -> LocalBuildInfo + -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) + -> IO () withBenchLBI pkg lbi f = - sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ] + sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi] -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI + :: PackageDescription + -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) + -> IO () withTestLBI pkg lbi f = - sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ] + sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi] -enabledTestLBIs :: PackageDescription -> LocalBuildInfo - -> [(TestSuite, ComponentLocalBuildInfo)] +enabledTestLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(TestSuite, ComponentLocalBuildInfo)] enabledTestLBIs pkg lbi = - [ (test, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CTest test <- [targetComponent target] ] + [ (test, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CTest test <- [targetComponent target] + ] -enabledBenchLBIs :: PackageDescription -> LocalBuildInfo - -> [(Benchmark, ComponentLocalBuildInfo)] +enabledBenchLBIs + :: PackageDescription + -> LocalBuildInfo + -> [(Benchmark, ComponentLocalBuildInfo)] enabledBenchLBIs pkg lbi = - [ (bench, targetCLBI target) - | target <- allTargetsInBuildOrder' pkg lbi - , CBench bench <- [targetComponent target] ] + [ (bench, targetCLBI target) + | target <- allTargetsInBuildOrder' pkg lbi + , CBench bench <- [targetComponent target] + ] -- | Perform the action on each buildable 'Library' or 'Executable' (Component) -- in the PackageDescription, subject to the build order specified by the -- 'compBuildOrder' field of the given 'LocalBuildInfo' -withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo - -> (Component -> ComponentLocalBuildInfo -> IO ()) - -> IO () +withAllComponentsInBuildOrder + :: PackageDescription + -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () withAllComponentsInBuildOrder pkg lbi f = - withAllTargetsInBuildOrder' pkg lbi $ \target -> - f (targetComponent target) (targetCLBI target) + withAllTargetsInBuildOrder' pkg lbi $ \target -> + f (targetComponent target) (targetCLBI target) -allComponentsInBuildOrder :: LocalBuildInfo - -> [ComponentLocalBuildInfo] -allComponentsInBuildOrder lbi = - Graph.topSort (componentGraph lbi) +allComponentsInBuildOrder + :: LocalBuildInfo + -> [ComponentLocalBuildInfo] +allComponentsInBuildOrder (LocalBuildInfo{componentGraph = compGraph}) = + Graph.topSort compGraph -- ----------------------------------------------------------------------------- -- A random function that has no business in this module @@ -186,42 +253,62 @@ -- transitive dependencies of the component we are building. -- -- When wanted, and possible, returns paths relative to the installDirs 'prefix' -depLibraryPaths :: Bool -- ^ Building for inplace? - -> Bool -- ^ Generate prefix-relative library paths - -> LocalBuildInfo - -> ComponentLocalBuildInfo -- ^ Component that is being built - -> IO [FilePath] -depLibraryPaths inplace relative lbi clbi = do - let pkgDescr = localPkgDescr lbi - installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest - executable = case clbi of - ExeComponentLocalBuildInfo {} -> True - _ -> False - relDir | executable = bindir installDirs - | otherwise = libdir installDirs +depLibraryPaths + :: Bool + -- ^ Building for inplace? + -> Bool + -- ^ Generate prefix-relative library paths + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -- ^ Component that is being built + -> IO [FilePath] +depLibraryPaths + inplace + relative + lbi@( LocalBuildInfo + { localPkgDescr = pkgDescr + , installedPkgs = installed + } + ) + clbi = do + let installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest + executable = case clbi of + ExeComponentLocalBuildInfo{} -> True + _ -> False + relDir + | executable = bindir installDirs + | otherwise = libdir installDirs - let -- TODO: this is kind of inefficient - internalDeps = [ uid - | (uid, _) <- componentPackageDeps clbi - -- Test that it's internal - , sub_target <- allTargetsInBuildOrder' pkgDescr lbi - , componentUnitId (targetCLBI (sub_target)) == uid ] - internalLibs = [ getLibDir (targetCLBI sub_target) - | sub_target <- neededTargetsInBuildOrder' - pkgDescr lbi internalDeps ] - {- - -- This is better, but it doesn't work, because we may be passed a - -- CLBI which doesn't actually exist, and was faked up when we - -- were building a test suite/benchmark. See #3599 for proposal - -- to fix this. - let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) - . map targetCLBI - $ neededTargetsInBuildOrder lbi [componentUnitId clbi] - internalLibs = map getLibDir internalCLBIs - -} - getLibDir sub_clbi - | inplace = componentBuildDir lbi sub_clbi - | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) + let + -- TODO: this is kind of inefficient + internalDeps = + [ uid + | (uid, _) <- componentPackageDeps clbi + , -- Test that it's internal + sub_target <- allTargetsInBuildOrder' pkgDescr lbi + , componentUnitId (targetCLBI (sub_target)) == uid + ] + internalLibs = + [ getLibDir (targetCLBI sub_target) + | sub_target <- + neededTargetsInBuildOrder' + pkgDescr + lbi + internalDeps + ] + {- + -- This is better, but it doesn't work, because we may be passed a + -- CLBI which doesn't actually exist, and was faked up when we + -- were building a test suite/benchmark. See #3599 for proposal + -- to fix this. + let internalCLBIs = filter ((/= componentUnitId clbi) . componentUnitId) + . map targetCLBI + $ neededTargetsInBuildOrder lbi [componentUnitId clbi] + internalLibs = map getLibDir internalCLBIs + -} + getLibDir sub_clbi + | inplace = interpretSymbolicPathLBI lbi $ componentBuildDir lbi sub_clbi + | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest) -- Why do we go through all the trouble of a hand-crafting -- internalLibs, when 'installedPkgs' actually contains the @@ -232,48 +319,54 @@ -- is a moot point if you are using a per-component build, -- because you never have any internal libraries in this case; -- they're all external. - let external_ipkgs = filter is_external (allPackages (installedPkgs lbi)) + let external_ipkgs = filter is_external (allPackages installed) is_external ipkg = not (installedUnitId ipkg `elem` internalDeps) -- First look for dynamic libraries in `dynamic-library-dirs`, and use -- `library-dirs` as a fall back. - getDynDir pkg = case Installed.libraryDynDirs pkg of - [] -> Installed.libraryDirs pkg - d -> d - allDepLibDirs = concatMap getDynDir external_ipkgs + getDynDir pkg = case Installed.libraryDynDirs pkg of + [] -> Installed.libraryDirs pkg + d -> d + allDepLibDirs = concatMap getDynDir external_ipkgs allDepLibDirs' = internalLibs ++ allDepLibDirs allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs' - let p = prefix installDirs + let p = prefix installDirs prefixRelative l = isJust (stripPrefix p l) libPaths - | relative && - prefixRelative relDir = map (\l -> - if prefixRelative l - then shortRelativePath relDir l - else l - ) allDepLibDirsC - | otherwise = allDepLibDirsC + | relative + && prefixRelative relDir = + map + ( \l -> + if prefixRelative l + then shortRelativePath relDir l + else l + ) + allDepLibDirsC + | otherwise = allDepLibDirsC - return libPaths - where - -- 'canonicalizePath' fails on UNIX when the directory does not exists. - -- So just don't canonicalize when it doesn't exist. - canonicalizePathNoFail p = do - exists <- doesDirectoryExist p - if exists - then canonicalizePath p - else return p + -- For some reason, this function returns lots of duplicates. Avoid + -- exceeding `ARG_MAX` (the result of this function is used to populate + -- `LD_LIBRARY_PATH`) by deduplicating the list. + return $ ordNub libPaths + where + -- 'canonicalizePath' fails on UNIX when the directory does not exists. + -- So just don't canonicalize when it doesn't exist. + canonicalizePathNoFail p = do + exists <- Directory.doesDirectoryExist p + if exists + then Directory.canonicalizePath p + else return p -- | Get all module names that needed to be built by GHC; i.e., all -- of these 'ModuleName's have interface files associated with them -- that need to be installed. allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName] allLibModules lib clbi = - ordNub $ - explicitLibModules lib ++ - case clbi of - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts + ordNub $ + explicitLibModules lib + ++ case clbi of + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts _ -> [] -- ----------------------------------------------------------------------------- @@ -283,49 +376,59 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'absoluteComponentInstallDirs' instead. -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo - -> CopyDest - -> InstallDirs FilePath +absoluteInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> CopyDest + -> InstallDirs FilePath absoluteInstallDirs pkg lbi copydest = - absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest + absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest -- | See 'InstallDirs.absoluteInstallDirs'. -absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath -absoluteComponentInstallDirs pkg lbi uid copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg) - uid - (compilerInfo (compiler lbi)) - copydest - (hostPlatform lbi) - (installDirTemplates lbi) +absoluteComponentInstallDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath +absoluteComponentInstallDirs + pkg + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid + copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + uid + (compilerInfo comp) + copydest + plat + installDirs -absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo - -> UnitId - -> CopyDest - -> InstallDirs FilePath +absoluteInstallCommandDirs + :: PackageDescription + -> LocalBuildInfo + -> UnitId + -> CopyDest + -> InstallDirs FilePath absoluteInstallCommandDirs pkg lbi uid copydest = - dirs { - -- Handle files which are not - -- per-component (data files and Haddock files.) - datadir = datadir dirs', - -- NB: The situation with Haddock is a bit delicate. On the - -- one hand, the easiest to understand Haddock documentation - -- path is pkgname-0.1, which means it's per-package (not - -- per-component). But this means that it's impossible to - -- install Haddock documentation for internal libraries. We'll - -- keep this constraint for now; this means you can't use - -- Cabal to Haddock internal libraries. This does not seem - -- like a big problem. - docdir = docdir dirs', - htmldir = htmldir dirs', - haddockdir = haddockdir dirs' + dirs + { -- Handle files which are not + -- per-component (data files and Haddock files.) + datadir = datadir dirs' + , -- NB: The situation with Haddock is a bit delicate. On the + -- one hand, the easiest to understand Haddock documentation + -- path is pkgname-0.1, which means it's per-package (not + -- per-component). But this means that it's impossible to + -- install Haddock documentation for internal libraries. We'll + -- keep this constraint for now; this means you can't use + -- Cabal to Haddock internal libraries. This does not seem + -- like a big problem. + docdir = docdir dirs' + , htmldir = htmldir dirs' + , haddockdir = haddockdir dirs' } where - dirs = absoluteComponentInstallDirs pkg lbi uid copydest + dirs = absoluteComponentInstallDirs pkg lbi uid copydest -- Notice use of 'absoluteInstallDirs' (not the -- per-component variant). This means for non-library -- packages we'll just pick a nondescriptive foo-0.1 @@ -335,31 +438,46 @@ -- assuming that @$libname@ points to the public library (or some fake -- package identifier if there is no public library.) IF AT ALL -- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead. -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs + :: PackageId + -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkg_descr lbi = - prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo - -> UnitId - -> InstallDirs (Maybe FilePath) -prefixRelativeComponentInstallDirs pkg_descr lbi uid = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) - (installDirTemplates lbi) + prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi) -substPathTemplate :: PackageId -> LocalBuildInfo - -> UnitId - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi uid = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - uid - (compilerInfo (compiler lbi)) - (hostPlatform lbi) +-- | See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeComponentInstallDirs + :: PackageId + -> LocalBuildInfo + -> UnitId + -> InstallDirs (Maybe FilePath) +prefixRelativeComponentInstallDirs + pkg_descr + (LocalBuildInfo{compiler = comp, hostPlatform = plat, installDirTemplates = installDirs}) + uid = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + uid + (compilerInfo comp) + plat + installDirs +substPathTemplate + :: PackageId + -> LocalBuildInfo + -> UnitId + -> PathTemplate + -> FilePath +substPathTemplate + pkgid + (LocalBuildInfo{compiler = comp, hostPlatform = plat}) + uid = + fromPathTemplate + . (InstallDirs.substPathTemplate env) + where + env = + initialPathTemplateEnv + pkgid + uid + (compilerInfo comp) + plat diff --git a/src/Distribution/Simple/PackageDescription.hs b/src/Distribution/Simple/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PackageDescription.hs @@ -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)) + ] diff --git a/src/Distribution/Simple/PackageIndex.hs b/src/Distribution/Simple/PackageIndex.hs --- a/src/Distribution/Simple/PackageIndex.hs +++ b/src/Distribution/Simple/PackageIndex.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.PackageIndex -- Copyright : (c) David Himmelstrup 2005, @@ -43,80 +43,82 @@ -- 'Distribution.Client.PackageIndex', which indexes packages only by -- 'PackageName' (this makes it suitable for indexing source packages, -- for which we don't know 'UnitId's.) --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - InstalledPackageIndex, - PackageIndex, - - -- * Creating an index - fromList, +module Distribution.Simple.PackageIndex + ( -- * Package index data type + InstalledPackageIndex + , PackageIndex - -- * Updates - merge, + -- * Creating an index + , fromList - insert, + -- * Updates + , merge + , insert + , deleteUnitId + , deleteSourcePackageId + , deletePackageName + -- deleteDependency, - deleteUnitId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, + -- * Queries - -- * Queries + -- ** Precise lookups + , lookupUnitId + , lookupComponentId + , lookupSourcePackageId + , lookupPackageId + , lookupPackageName + , lookupInternalPackageName + , lookupDependency + , lookupInternalDependency - -- ** Precise lookups - lookupUnitId, - lookupComponentId, - lookupSourcePackageId, - lookupPackageId, - lookupPackageName, - lookupDependency, - lookupInternalDependency, + -- ** Case-insensitive searches + , searchByName + , SearchResult (..) + , searchByNameSubstring + , searchWithPredicate - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - searchWithPredicate, + -- ** Bulk queries + , allPackages + , allPackagesByName + , allPackagesBySourcePackageId + , allPackagesBySourcePackageIdAndLibName - -- ** Bulk queries - allPackages, - allPackagesByName, - allPackagesBySourcePackageId, - allPackagesBySourcePackageIdAndLibName, + -- ** Special queries + , brokenPackages + , dependencyClosure + , reverseDependencyClosure + , topologicalOrder + , reverseTopologicalOrder + , dependencyInconsistencies + , dependencyCycles + , dependencyGraph + , moduleNameIndex - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - moduleNameIndex + -- ** Filters on lookup results + , eligibleDependencies + , matchingDependencies ) where -import Prelude () -import Distribution.Compat.Prelude hiding (lookup) import qualified Data.Map.Strict as Map +import Distribution.Compat.Prelude hiding (lookup) +import Prelude () -import Distribution.Package import Distribution.Backpack -import Distribution.ModuleName import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version +import Distribution.ModuleName +import Distribution.Package import Distribution.Simple.Utils import Distribution.Types.LibraryName +import Distribution.Version import Control.Exception (assert) +import Control.Monad import Data.Array ((!)) import qualified Data.Array as Array import qualified Data.Graph as Graph -import Data.List as List ( groupBy, deleteBy, deleteFirstsBy ) +import Data.List as List (deleteBy, deleteFirstsBy, groupBy) import qualified Data.List.NonEmpty as NE -import qualified Data.Tree as Tree -import Control.Monad +import qualified Data.Tree as Tree import Distribution.Compat.Stack import qualified Prelude (foldr1) @@ -126,27 +128,25 @@ -- -- Packages are uniquely identified in by their 'UnitId', they can -- also be efficiently looked up by package name or by name and version. --- -data PackageIndex a = PackageIndex { - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its UnitId. - -- - unitIdIndex :: !(Map UnitId a), - - -- This auxiliary index maps package names (case-sensitively) to all the - -- versions and instances of that package. This allows us to find all - -- versions satisfying a dependency. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by UnitId - -- and are kept in preference order. - -- - -- FIXME: Clarify what "preference order" means. Check that this invariant is - -- preserved. See #1463 for discussion. - packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) - - } deriving (Eq, Generic, Show, Read, Typeable) +data PackageIndex a = PackageIndex + { -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its UnitId. + -- + unitIdIndex :: !(Map UnitId a) + , -- This auxiliary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by UnitId + -- and are kept in preference order. + -- + -- FIXME: Clarify what "preference order" means. Check that this invariant is + -- preserved. See #1463 for discussion. + packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a])) + } + deriving (Eq, Generic, Show, Read) instance Binary a => Binary (PackageIndex a) instance Structured a => Structured (PackageIndex a) @@ -156,9 +156,10 @@ type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo instance Monoid (PackageIndex IPI.InstalledPackageInfo) where - mempty = PackageIndex Map.empty Map.empty + mempty = PackageIndex Map.empty Map.empty mappend = (<>) - --save one mappend with empty in the common case: + + -- save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = Prelude.foldr1 mappend xs @@ -170,69 +171,84 @@ invariant (PackageIndex pids pnames) = -- trace (show pids' ++ "\n" ++ show pnames') $ pids' == pnames' - where - pids' = map installedUnitId (Map.elems pids) - pnames' = sort - [ assert pinstOk (installedUnitId pinst) - | ((pname, plib), pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedUnitId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedUnitId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname + where + pids' = map installedUnitId (Map.elems pids) + pnames' = + sort + [ assert pinstOk (installedUnitId pinst) + | ((pname, plib), pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedUnitId) pinsts + pinstsOk = + all + (\g -> length g == 1) + (groupBy (equating installedUnitId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = + packageName pinst == pname && packageVersion pinst == pver - && IPI.sourceLibName pinst == plib - ] - -- If you see this invariant failing (ie the assert in mkPackageIndex below) - -- then one thing to check is if it is happening in fromList. Check if the - -- second list above (the sort [...] bit) is ending up with duplicates. This - -- has been observed in practice once due to a messed up ghc-pkg db. How/why - -- it became messed up was not discovered. + && IPI.sourceLibName pinst == plib + ] +-- If you see this invariant failing (ie the assert in mkPackageIndex below) +-- then one thing to check is if it is happening in fromList. Check if the +-- second list above (the sort [...] bit) is ending up with duplicates. This +-- has been observed in practice once due to a messed up ghc-pkg db. How/why +-- it became messed up was not discovered. -- + -- * Internal helpers + -- -mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo - -> Map (PackageName, LibraryName) - (Map Version [IPI.InstalledPackageInfo]) - -> InstalledPackageIndex) +mkPackageIndex + :: WithCallStack + ( Map UnitId IPI.InstalledPackageInfo + -> Map + (PackageName, LibraryName) + (Map Version [IPI.InstalledPackageInfo]) + -> InstalledPackageIndex + ) mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - + where + index = PackageIndex pids pnames -- + -- * Construction + -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates by 'UnitId' then later ones mask earlier -- ones. --- fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames) where - pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ] - pnames = + pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs] + pnames = Map.fromList [ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers) - | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) - . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) - $ pkgs + | pkgsN <- + NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName)) + . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion)) + $ pkgs , let pvers = Map.fromList - [ (packageVersion (NE.head pkgsNV), - NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)) - | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN - ] + [ ( packageVersion (NE.head pkgsNV) + , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV) + ) + | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN + ] ] -- + -- * Updates + -- -- | Merge two indexes. @@ -244,101 +260,110 @@ -- \"preferred\" over those from the first. Being preferred means they are top -- result when we do a lookup by source 'PackageId'. This is the mechanism we -- use to prefer user packages over global packages. --- -merge :: InstalledPackageIndex -> InstalledPackageIndex - -> InstalledPackageIndex +merge + :: InstalledPackageIndex + -> InstalledPackageIndex + -> InstalledPackageIndex merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + mkPackageIndex + (Map.unionWith (\_ y -> y) pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) where -- Packages in the second list mask those in the first, however preferred -- packages go first in the list. mergeBuckets xs ys = ys ++ (xs \\ ys) (\\) = deleteFirstsBy (equating installedUnitId) - -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. --- insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - + mkPackageIndex pids' pnames' where - pids' = Map.insert (installedUnitId pkg) pkg pids + pids' = Map.insert (installedUnitId pkg) pkg pids pnames' = insertPackageName pnames insertPackageName = - Map.insertWith (\_ -> insertPackageVersion) - (packageName pkg, IPI.sourceLibName pkg) - (Map.singleton (packageVersion pkg) [pkg]) + Map.insertWith + (\_ -> insertPackageVersion) + (packageName pkg, IPI.sourceLibName pkg) + (Map.singleton (packageVersion pkg) [pkg]) insertPackageVersion = - Map.insertWith (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] + Map.insertWith + (\_ -> insertPackageInstance) + (packageVersion pkg) + [pkg] insertPackageInstance pkgs = pkg : deleteBy (equating installedUnitId) pkg pkgs - -- | Removes a single installed package from the index. --- -deleteUnitId :: UnitId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteUnitId + :: UnitId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteUnitId ipkgid original@(PackageIndex pids pnames) = case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - + (Nothing, _) -> original + (Just spkgid, pids') -> + mkPackageIndex + pids' + (deletePkgName spkgid pnames) where deletePkgName spkgid = Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid) deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) deletePkgInstance = - (\xs -> if null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined + (\xs -> if null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined -- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> InstalledPackageIndex - -> InstalledPackageIndex +deleteSourcePackageId + :: PackageId + -> InstalledPackageIndex + -> InstalledPackageIndex deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = -- NB: Doesn't delete internal packages case Map.lookup (packageName pkgid, LMainLibName) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) - (deletePkgName pnames) + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> + mkPackageIndex + (foldl' (flip (Map.delete . installedUnitId)) pids pkgs) + (deletePkgName pnames) where deletePkgName = Map.update deletePkgVersion (packageName pkgid, LMainLibName) deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- -- NB: Does NOT delete internal libraries from this package. --- -deletePackageName :: PackageName -> InstalledPackageIndex - -> InstalledPackageIndex +deletePackageName + :: PackageName + -> InstalledPackageIndex + -> InstalledPackageIndex deletePackageName name original@(PackageIndex pids pnames) = case Map.lookup (name, LMainLibName) pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedUnitId)) pids - (concat (Map.elems pvers))) - (Map.delete (name, LMainLibName) pnames) + Nothing -> original + Just pvers -> + mkPackageIndex + ( foldl' + (flip (Map.delete . installedUnitId)) + pids + (concat (Map.elems pvers)) + ) + (Map.delete (name, LMainLibName) pnames) {- -- | Removes all packages satisfying this dependency from the index. @@ -349,11 +374,12 @@ -} -- + -- * Bulk queries + -- -- | Get all the packages from the index. --- allPackages :: PackageIndex a -> [a] allPackages = Map.elems . unitIdIndex @@ -362,91 +388,110 @@ -- They are grouped by package name (case-sensitively). -- -- (Doesn't include private libraries.) --- allPackagesByName :: PackageIndex a -> [(PackageName, [a])] allPackagesByName index = [ (pkgname, concat (Map.elems pvers)) - | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ] + | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + ] -- | Get all the packages from the index. -- -- They are grouped by source package id (package name and version). -- -- (Doesn't include private libraries) --- -allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a - -> [(PackageId, [a])] +allPackagesBySourcePackageId + :: HasUnitId a + => PackageIndex a + -> [(PackageId, [a])] allPackagesBySourcePackageId index = [ (packageId ipkg, ipkgs) | ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- | Get all the packages from the index. -- -- They are grouped by source package id and library name. -- -- This DOES include internal libraries. -allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a - -> [((PackageId, LibraryName), [a])] +allPackagesBySourcePackageIdAndLibName + :: HasUnitId a + => PackageIndex a + -> [((PackageId, LibraryName), [a])] allPackagesBySourcePackageIdAndLibName index = [ ((packageId ipkg, ln), ipkgs) | ((_, ln), pvers) <- Map.toList (packageIdIndex index) - , ipkgs@(ipkg:_) <- Map.elems pvers ] + , ipkgs@(ipkg : _) <- Map.elems pvers + ] -- + -- * Lookups + -- -- | Does a lookup by unit identifier. -- -- Since multiple package DBs mask each other by 'UnitId', -- then we get back at most one package. --- -lookupUnitId :: PackageIndex a -> UnitId - -> Maybe a +lookupUnitId + :: PackageIndex a + -> UnitId + -> Maybe a lookupUnitId index uid = Map.lookup uid (unitIdIndex index) -- | Does a lookup by component identifier. In the absence -- of Backpack, this is just a 'lookupUnitId'. --- -lookupComponentId :: PackageIndex a -> ComponentId - -> Maybe a +lookupComponentId + :: PackageIndex a + -> ComponentId + -> Maybe a lookupComponentId index cid = - Map.lookup (newSimpleUnitId cid) (unitIdIndex index) + Map.lookup (newSimpleUnitId cid) (unitIdIndex index) -- | Does a lookup by source package id (name & version). -- -- There can be multiple installed packages with the same source 'PackageId' -- but different 'UnitId'. They are returned in order of -- preference, with the most preferred first. --- lookupSourcePackageId :: PackageIndex a -> PackageId -> [a] lookupSourcePackageId index pkgid = -- Do not lookup internal libraries case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] Just pkgs -> pkgs -- in preference order -- | Convenient alias of 'lookupSourcePackageId', but assuming only -- one package per package ID. lookupPackageId :: PackageIndex a -> PackageId -> Maybe a -lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of - [] -> Nothing - [pkg] -> Just pkg - _ -> error "Distribution.Simple.PackageIndex: multiple matches found" +lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of + [] -> Nothing + [pkg] -> Just pkg + _ -> error "Distribution.Simple.PackageIndex: multiple matches found" -- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex a -> PackageName - -> [(Version, [a])] +lookupPackageName + :: PackageIndex a + -> PackageName + -> [(Version, [a])] lookupPackageName index name = -- Do not match internal libraries - case Map.lookup (name, LMainLibName) (packageIdIndex index) of - Nothing -> [] - Just pvers -> Map.toList pvers + lookupInternalPackageName index name LMainLibName +-- | Does a lookup by source package name and library name. +-- +-- Also looks up internal packages. +lookupInternalPackageName + :: PackageIndex a + -> PackageName + -> LibraryName + -> [(Version, [a])] +lookupInternalPackageName index name library = + case Map.lookup (name, library) (packageIdIndex index) of + Nothing -> [] + Just pvers -> Map.toList pvers -- | Does a lookup by source package name and a range of versions. -- @@ -457,12 +502,14 @@ -- function on those; use 'lookupInternalDependency' instead. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> [(Version, [IPI.InstalledPackageInfo])] +lookupDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] lookupDependency index pn vr = - -- Yes, a little bit of a misnomer here! - lookupInternalDependency index pn vr LMainLibName + -- Yes, a little bit of a misnomer here! + lookupInternalDependency index pn vr LMainLibName -- | Does a lookup by source package name and a range of versions. -- @@ -470,30 +517,57 @@ -- satisfying the version range constraint. -- -- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. --- -lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange - -> LibraryName - -> [(Version, [IPI.InstalledPackageInfo])] +lookupInternalDependency + :: InstalledPackageIndex + -> PackageName + -> VersionRange + -> LibraryName + -> [(Version, [IPI.InstalledPackageInfo])] lookupInternalDependency index name versionRange libn = - case Map.lookup (name, libn) (packageIdIndex index) of - Nothing -> [] - Just pvers -> [ (ver, pkgs') - | (ver, pkgs) <- Map.toList pvers - , ver `withinRange` versionRange - , let pkgs' = filter eligible pkgs - -- Enforce the invariant - , not (null pkgs') - ] - where - -- When we select for dependencies, we ONLY want to pick up indefinite - -- packages, or packages with no instantiations. We'll do mix-in - -- linking to improve any such package into an instantiated one - -- later. - eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) + matchingDependencies versionRange $ + lookupInternalPackageName index name libn +-- | Filter a set of installed packages to ones eligible as dependencies. +-- +-- When we select for dependencies, we ONLY want to pick up indefinite +-- packages, or packages with no instantiations. We'll do mix-in linking to +-- improve any such package into an instantiated one later. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +eligibleDependencies + :: [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +eligibleDependencies versions = + [ (ver, pkgs') + | (ver, pkgs) <- versions + , let pkgs' = filter eligible pkgs + , -- Enforce the invariant + not (null pkgs') + ] + where + eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg) +-- | Get eligible dependencies from a list of versions. -- +-- This can be used to filter the output of 'lookupPackageName' or +-- 'lookupInternalPackageName'. +-- +-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty. +matchingDependencies + :: VersionRange + -> [(Version, [IPI.InstalledPackageInfo])] + -> [(Version, [IPI.InstalledPackageInfo])] +matchingDependencies versionRange versions = + let eligibleVersions = eligibleDependencies versions + in [ (ver, pkgs) + | (ver, pkgs) <- eligibleVersions + , ver `withinRange` versionRange + ] + +-- + -- * Case insensitive name lookups + -- -- | Does a case-insensitive search by package name. @@ -507,42 +581,45 @@ -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. --- searchByName :: PackageIndex a -> String -> SearchResult [a] searchByName index name = -- Don't match internal packages - case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index) - , lowercase (unPackageName pname) == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name + case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname + ] of + [] -> None + [(_, pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of + Just (_, pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where + lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. --- searchByNameSubstring :: PackageIndex a -> String -> [a] searchByNameSubstring index searchterm = searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) - where lsearchterm = lowercase searchterm + where + lsearchterm = lowercase searchterm -- | @since 3.4.0.0 searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a] searchWithPredicate index predicate = [ pkg - -- Don't match internal packages - | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) + | -- Don't match internal packages + ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) , predicate (unPackageName pname) , pkgs <- Map.elems pvers - , pkg <- pkgs ] + , pkg <- pkgs + ] -- + -- * Special queries + -- -- None of the stuff below depends on the internal representation of the index. @@ -554,27 +631,30 @@ -- This actually computes the strongly connected components. So it gives us a -- list of groups of packages where within each group they all depend on each -- other, directly or indirectly. --- dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]] dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList] where - adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg) - | pkg <- allPackages index ] - + adjacencyList = + [ (pkg, installedUnitId pkg, installedDepends pkg) + | pkg <- allPackages index + ] -- | All packages that have immediate dependencies that are not in the index. -- -- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageInstalled a => PackageIndex a - -> [(a, [UnitId])] +brokenPackages + :: PackageInstalled a + => PackageIndex a + -> [(a, [UnitId])] brokenPackages index = [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- installedDepends pkg - , isNothing (lookupUnitId index pkg') ] - , not (null missing) ] + | pkg <- allPackages index + , let missing = + [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg') + ] + , not (null missing) + ] -- | Tries to take the transitive closure of the package dependencies. -- @@ -583,78 +663,89 @@ -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageId's do not occur in the index. --- -dependencyClosure :: InstalledPackageIndex - -> [UnitId] - -> Either (InstalledPackageIndex) - [(IPI.InstalledPackageInfo, [UnitId])] +dependencyClosure + :: InstalledPackageIndex + -> [UnitId] + -> Either + (InstalledPackageIndex) + [(IPI.InstalledPackageInfo, [UnitId])] dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupUnitId completed (installedUnitId pkg) of - Just _ -> closure completed failed pkgids + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of + Nothing -> closure completed (pkgid : failed) pkgids + Just pkg -> case lookupUnitId completed (installedUnitId pkg) of + Just _ -> closure completed failed pkgids Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = installedDepends pkg ++ pkgids + where + completed' = insert pkg completed + pkgids' = installedDepends pkg ++ pkgids -- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageInstalled a => PackageIndex a - -> [UnitId] - -> [a] +reverseDependencyClosure + :: PackageInstalled a + => PackageIndex a + -> [UnitId] + -> [a] reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) where (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index reverseDepGraph = Graph.transposeG depGraph noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" topologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index +topologicalOrder index = + map toPkgId + . Graph.topSort + $ graph + where + (graph, toPkgId, _) = dependencyGraph index reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index +reverseTopologicalOrder index = + map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where + (graph, toPkgId, _) = dependencyGraph index -- | Builds a graph of the package dependencies. -- -- Dependencies on other packages that are not in the index are discarded. -- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageInstalled a => PackageIndex a - -> (Graph.Graph, - Graph.Vertex -> a, - UnitId -> Maybe Graph.Vertex) +dependencyGraph + :: PackageInstalled a + => PackageIndex a + -> ( Graph.Graph + , Graph.Vertex -> a + , UnitId -> Maybe Graph.Vertex + ) dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) where - graph = Array.listArray bounds - [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ] - | pkg <- pkgs ] + graph = + Array.listArray + bounds + [ [v | Just v <- map id_to_vertex (installedDepends pkg)] + | pkg <- pkgs + ] - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedUnitId pkgs) [0..] - vertex_map = Map.fromList vertices + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedUnitId pkgs) [0 ..] + vertex_map = Map.fromList vertices id_to_vertex pid = Map.lookup pid vertex_map vertex_to_pkg vertex = pkgTable ! vertex - pkgTable = Array.listArray bounds pkgs + pkgTable = Array.listArray bounds pkgs topBound = length pkgs - 1 bounds = (0, topBound) @@ -671,29 +762,36 @@ -- Each element in the result is a package name along with the packages that -- depend on it and the versions they require. These are guaranteed to be -- distinct. --- -dependencyInconsistencies :: InstalledPackageIndex - -- At DepUniqueKey... - -> [(DepUniqueKey, - -- There were multiple packages (BAD!) - [(UnitId, - -- And here are the packages which - -- immediately depended on it - [IPI.InstalledPackageInfo])])] +dependencyInconsistencies + :: InstalledPackageIndex + -- At DepUniqueKey... + -> [ ( DepUniqueKey + , -- There were multiple packages (BAD!) + [ ( UnitId + , -- And here are the packages which + -- immediately depended on it + [IPI.InstalledPackageInfo] + ) + ] + ) + ] dependencyInconsistencies index = do - (dep_key, insts_map) <- Map.toList inverseIndex - let insts = Map.toList insts_map - guard (length insts >= 2) - return (dep_key, insts) + (dep_key, insts_map) <- Map.toList inverseIndex + let insts = Map.toList insts_map + guard (length insts >= 2) + return (dep_key, insts) where inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo]) inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do - pkg <- allPackages index - dep_ipid <- installedDepends pkg - Just dep <- [lookupUnitId index dep_ipid] - let dep_key = (packageName dep, IPI.sourceLibName dep, - Map.fromList (IPI.instantiatedWith dep)) - return (dep_key, Map.singleton dep_ipid [pkg]) + pkg <- allPackages index + dep_ipid <- installedDepends pkg + Just dep <- [lookupUnitId index dep_ipid] + let dep_key = + ( packageName dep + , IPI.sourceLibName dep + , Map.fromList (IPI.instantiatedWith dep) + ) + return (dep_key, Map.singleton dep_ipid [pkg]) -- | A rough approximation of GHC's module finder, takes a -- 'InstalledPackageIndex' and turns it into a map from module names to their @@ -705,12 +803,14 @@ pkg <- allPackages index IPI.ExposedModule m reexport <- IPI.exposedModules pkg case reexport of - Nothing -> return (m, [pkg]) - Just (OpenModuleVar _) -> [] - Just (OpenModule _ m') | m == m' -> [] - | otherwise -> return (m', [pkg]) - -- The heuristic is this: we want to prefer the original package - -- which originally exported a module. However, if a reexport - -- also *renamed* the module (m /= m'), then we have to use the - -- downstream package, since the upstream package has the wrong - -- module name! + Nothing -> return (m, [pkg]) + Just (OpenModuleVar _) -> [] + Just (OpenModule _ m') + | m == m' -> [] + | otherwise -> return (m', [pkg]) + +-- The heuristic is this: we want to prefer the original package +-- which originally exported a module. However, if a reexport +-- also *renamed* the module (m /= m'), then we have to use the +-- downstream package, since the upstream package has the wrong +-- module name! diff --git a/src/Distribution/Simple/PreProcess.hs b/src/Distribution/Simple/PreProcess.hs --- a/src/Distribution/Simple/PreProcess.hs +++ b/src/Distribution/Simple/PreProcess.hs @@ -1,779 +1,932 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess --- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'PreProcessor' abstraction which represents a pre-processor --- that can transform one kind of file into another. There is also a --- 'PPSuffixHandler' which is a combination of a file extension and a function --- for configuring a 'PreProcessor'. It defines a bunch of known built-in --- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and --- lists them in 'knownSuffixHandlers'. On top of this it provides a function --- for actually preprocessing some sources given a bunch of known suffix --- handlers. This module is not as good as it could be, it could really do with --- a rewrite to address some of the problems we have with pre-processors. - -module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras, - knownSuffixHandlers, ppSuffixes, - PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit, platformDefines - ) - where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Compat.Stack - -import Distribution.Simple.PreProcess.Unlit -import Distribution.Backpack.DescribeUnitId -import Distribution.Package -import qualified Distribution.ModuleName as ModuleName -import Distribution.ModuleName (ModuleName) -import Distribution.PackageDescription as PD -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.CCompiler -import Distribution.Simple.Compiler -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.Program.ResponseFile -import Distribution.Simple.Test.LibV09 -import Distribution.System -import Distribution.Pretty -import Distribution.Version -import Distribution.Verbosity -import Distribution.Utils.Path - -import System.Directory (doesFileExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension, - takeExtensions) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other generated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the generated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- included into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementation dependent output - -- eg alex and happy have --ghc flags. However we can't really include - -- ghc-specific code into supposedly portable source tarballs. - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - --- | Function to determine paths to possible extra C sources for a --- preprocessor: just takes the path to the build directory and uses --- this to search for C sources with names that match the --- preprocessor's output name format. -type PreProcessorExtras = FilePath -> IO [FilePath] - - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) - --- | Apply preprocessors to the sources from 'hsSourceDirs' for a given --- component (lib, exe, or test suite). --- --- XXX: This is terrible -preprocessComponent :: PackageDescription - -> Component - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Verbosity - -> [PPSuffixHandler] - -> IO () -preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = do - -- NB: never report instantiation here; we'll report it properly when - -- building. - setupMessage' verbosity "Preprocessing" (packageId pd) - (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)]) - case comp of - (CLib lib@Library{ libBuildInfo = bi }) -> do - let dirs = map getSymbolicPath (hsSourceDirs bi) ++ - [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ allLibModules lib clbi) $ - pre dirs (componentBuildDir lbi clbi) (localHandlers bi) - (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - let flibDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ foreignLibModules flib) $ - pre dirs flibDir (localHandlers bi) - (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do - let nm' = unUnqualComponentName nm - let exeDir = buildDir lbi nm' nm' ++ "-tmp" - dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi - ,autogenPackageModulesDir lbi] - for_ (map ModuleName.toFilePath $ otherModules bi) $ - pre dirs exeDir (localHandlers bi) - pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $ - dropExtensions (modulePath exe) - CTest test@TestSuite{ testName = nm } -> do - let nm' = unUnqualComponentName nm - case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test " - ++ "suite type " ++ prettyShow tt - CBench bm@Benchmark{ benchmarkName = nm } -> do - let nm' = unUnqualComponentName nm - case benchmarkInterface bm of - BenchmarkExeV10 _ f -> - preProcessBench bm f $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"] - builtinCSuffixes = cSourceExtensions - builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes - localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] - pre dirs dir lhndlrs fp = - preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs - preProcessTest test = preProcessComponent (testBuildInfo test) - (testModules test) - preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm) - (benchmarkModules bm) - - preProcessComponent - :: BuildInfo - -> [ModuleName] - -> FilePath - -> FilePath - -> IO () - preProcessComponent bi modules exePath dir = do - let biHandlers = localHandlers bi - sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi - , autogenPackageModulesDir lbi ] - sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers - | modu <- modules ] - - -- XXX: what we do here (re SymbolicPath dir) - -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir? - preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers - ---TODO: try to list all the modules that could not be found --- not just the first one. It's annoying and slow due to the need --- to reconfigure after editing the .cabal file each time. - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessFile - :: [SymbolicPath PackageDir SourceDir] -- ^ source directories - - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile - case bsrcFiles of - Nothing -> - die' verbosity $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc) - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected") - (lookup (safeTail ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> - psrcFile `moreRecentFile` ppsrcFile - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - - where - dirName = takeDirectory - - -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs file in dist/ - -- then we need to copy the hs-boot file there too. This should probably be - -- done another way. Possibly we should also be looking for .lhs-boot - -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) = do - runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity - - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGreenCard _ lbi _ - = PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpp' extraArgs bi lbi clbi = - case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi - GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi - _ -> ppCpphs args bi lbi clbi - where cppArgs = getCppOptions bi lbi - args = cppArgs ++ extraArgs - -ppGhcCpp :: Program -> (Version -> Bool) - -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppGhcCpp program xHs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (prog, version, _) <- requireProgramVersion verbosity - program anyVersion (withPrograms lbi) - runProgram verbosity prog $ - ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if xHs version then ["-x", "hs"] else []) - ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - runProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= mkVersion [1,6] - then ["--include="++ (autogenComponentModulesDir lbi clbi cppHeaderName)] - else []) - ++ extraArgs - } - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity - hsc2hsProgram anyVersion (withPrograms lbi) - -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. - let isCross = hostPlatform lbi /= buildPlatform - prependCrossFlags = if isCross then ("-x":) else id - let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4] - pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile - if hsc2hsSupportsResponseFiles - then withResponseFile - verbosity - defaultTempFileOptions - (takeDirectory outFile) - "hsc2hs-response.txt" - Nothing - pureArgs - (\responseFileName -> - runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName])) - else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs) - } - where - -- Returns a list of command line arguments that can either be passed - -- directly, or via a response file. - genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] - genPureArgs hsc2hsVersion gccProg inFile outFile = - -- Additional gcc options - [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] - - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ] - - -- Options from the current package: - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=-I" ++ buildDir lbi dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi - -- hsc2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- DO NOT add PD.cxxOptions unless this changes! - ] - ++ [ "--cflag=" ++ opt | opt <- - [ "-I" ++ autogenComponentModulesDir lbi clbi, - "-I" ++ autogenPackageModulesDir lbi, - "-include", autogenComponentModulesDir lbi clbi cppHeaderName ] ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] - - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ preccldFlags - ++ hsc2hsOptions bi - ++ postccldFlags - - ++ ["-o", outFile, inFile] - where - -- hsc2hs flag parsing was wrong - -- (see -- https://github.com/haskell/hsc2hs/issues/35) - -- so we need to put -- --cc/--ld *after* hsc2hsOptions, - -- for older hsc2hs (pre 0.68.8) so that they can be overridden. - ccldFlags = - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg - ] - - (preccldFlags, postccldFlags) - | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, []) - | otherwise = ([], ccldFlags) - - hacked_index = packageHacks (installedPkgs lbi) - -- Look only at the dependencies of the current component - -- being built! This relies on 'installedPkgs' maintaining - -- 'InstalledPackageInfo' for internal deps too; see #2971. - pkgs = PackageIndex.topologicalOrder $ - case PackageIndex.dependencyClosure hacked_index - (map fst (componentPackageDeps clbi)) of - Left index' -> index' - Right inf -> - error ("ppHsc2hs: broken closure: " ++ show inf) - isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True; - packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage - GHCJS -> hackRtsPackage - _ -> id - -- We don't link in the actual Haskell libraries of our dependencies, so - -- the -u flags in the ldOptions of the rts package mean linking fails on - -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the - -- ldOptions for GHC's rts package: - hackRtsPackage index = - case PackageIndex.lookupPackageName index (mkPackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" - -ppHsc2hsExtras :: PreProcessorExtras -ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap` - getDirectoryContentsRecursive buildBaseDir - -ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppC2hs bi lbi clbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (mkVersion [0,15])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - runProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi cppHeaderName) ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - -- c2hs uses the C ABI - -- We assume that there are only C sources - -- and C++ functions are exported via a C - -- interface and wrapped in a C source file. - -- Therefore we do not supply C++ flags - -- because there will not be C++ sources. - -- - -- - -- DO NOT add Installed.cxxOptions unless this changes! - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } - where - pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) - -ppC2hsExtras :: PreProcessorExtras -ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap` - getDirectoryContentsRecursive d - ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 ---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC --- instead of combining all these cases in a single function. This blind combination can --- potentially lead to compilation inconsistencies. -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = platformDefines lbi - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] - -platformDefines :: LocalBuildInfo -> [String] -platformDefines lbi = - case compilerFlavor comp of - GHC -> - ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - GHCJS -> - compatGlasgowHaskell ++ - ["-D__GHCJS__=" ++ versionInt version] ++ - ["-D" ++ os ++ "_BUILD_OS=1"] ++ - ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - HaskellSuite {} -> - ["-D__HASKELL_SUITE__"] ++ - map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++ - map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr - _ -> [] - where - comp = compiler lbi - Platform hostArch hostOS = hostPlatform lbi - version = compilerVersion comp - compatGlasgowHaskell = - maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) - (compilerCompatVersion GHC comp) - -- TODO: move this into the compiler abstraction - -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all - -- the other compilers. Check if that's really what they want. - versionInt :: Version -> String - versionInt v = case versionNumbers v of - [] -> "1" - [n] -> show n - n1:n2:_ -> - -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - - osStr = case hostOS of - Linux -> ["linux"] - Windows -> ["mingw32"] - OSX -> ["darwin"] - FreeBSD -> ["freebsd"] - OpenBSD -> ["openbsd"] - NetBSD -> ["netbsd"] - DragonFly -> ["dragonfly"] - Solaris -> ["solaris2"] - AIX -> ["aix"] - HPUX -> ["hpux"] - IRIX -> ["irix"] - HaLVM -> [] - IOS -> ["ios"] - Android -> ["android"] - Ghcjs -> ["ghcjs"] - Hurd -> ["hurd"] - OtherOS _ -> [] - archStr = case hostArch of - I386 -> ["i386"] - X86_64 -> ["x86_64"] - PPC -> ["powerpc"] - PPC64 -> ["powerpc64"] - Sparc -> ["sparc"] - Arm -> ["arm"] - AArch64 -> ["aarch64"] - Mips -> ["mips"] - SH -> [] - IA64 -> ["ia64"] - S390 -> ["s390"] - Alpha -> ["alpha"] - Hppa -> ["hppa"] - Rs6000 -> ["rs6000"] - M68k -> ["m68k"] - Vax -> ["vax"] - JavaScript -> ["javascript"] - OtherArch _ -> [] - -ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppHappy _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags GHCJS = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor -ppAlex _ lbi _ = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags GHCJS = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - runDbProgram verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] - --- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs. -knownExtrasHandlers :: [ PreProcessorExtras ] -knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ] - --- | Find any extra C sources generated by preprocessing that need to --- be added to the component (addresses issue #238). -preprocessExtras :: Verbosity - -> Component - -> LocalBuildInfo - -> IO [FilePath] -preprocessExtras verbosity comp lbi = case comp of - CLib _ -> pp $ buildDir lbi - (CExe Executable { exeName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - (CFLib ForeignLib { foreignLibName = nm }) -> do - let nm' = unUnqualComponentName nm - pp $ buildDir lbi nm' nm' ++ "-tmp" - CTest test -> do - let nm' = unUnqualComponentName $ testName test - case testInterface test of - TestSuiteExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - TestSuiteLibV09 _ _ -> - pp $ buildDir lbi stubName test stubName test ++ "-tmp" - TestSuiteUnsupported tt -> - die' verbosity $ "No support for preprocessing test suite type " ++ - prettyShow tt - CBench bm -> do - let nm' = unUnqualComponentName $ benchmarkName bm - case benchmarkInterface bm of - BenchmarkExeV10 _ _ -> - pp $ buildDir lbi nm' nm' ++ "-tmp" - BenchmarkUnsupported tt -> - die' verbosity $ "No support for preprocessing benchmark " - ++ "type " ++ prettyShow tt - where - pp :: FilePath -> IO [FilePath] - pp dir = (map (dir ) . filter not_sub . concat) - <$> for knownExtrasHandlers - (withLexicalCallStack (\f -> f dir)) - -- TODO: This is a terrible hack to work around #3545 while we don't - -- reorganize the directory layout. Basically, for the main - -- library, we might accidentally pick up autogenerated sources for - -- our subcomponents, because they are all stored as subdirectories - -- in dist/build. This is a cheap and cheerful check to prevent - -- this from happening. It is not particularly correct; for example - -- if a user has a test suite named foobar and puts their C file in - -- foobar/foo.c, this test will incorrectly exclude it. But I - -- didn't want to break BC... - not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ] - component_dirs = component_names (localPkgDescr lbi) - -- TODO: libify me - component_names pkg_descr = fmap unUnqualComponentName $ - mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++ - map exeName (executables pkg_descr) ++ - map testName (testSuites pkg_descr) ++ - map benchmarkName (benchmarks pkg_descr) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines 'PPSuffixHandler', which is a combination of a file +-- extension and a function for configuring a 'PreProcessor'. It also defines +-- a bunch of known built-in preprocessors like @cpp@, @cpphs@, @c2hs@, +-- @hsc2hs@, @happy@, @alex@ etc and lists them in 'knownSuffixHandlers'. +-- On top of this it provides a function for actually preprocessing some sources +-- given a bunch of known suffix handlers. +-- This module is not as good as it could be, it could really do with a rewrite +-- to address some of the problems we have with pre-processors. +module Distribution.Simple.PreProcess + ( preprocessComponent + , preprocessExtras + , preprocessFile + , knownSuffixHandlers + , ppSuffixes + , PPSuffixHandler + , Suffix (..) + , builtinHaskellSuffixes + , builtinHaskellBootSuffixes + , PreProcessor (..) + , mkSimplePreProcessor + , runSimplePreProcessor + , ppCpp + , ppCpp' + , ppC2hs + , ppHsc2hs + , ppHappy + , ppAlex + , ppUnlit + , platformDefines + , unsorted + ) +where + +import Distribution.Compat.Prelude +import Distribution.Compat.Stack +import Prelude () + +import Distribution.Backpack.DescribeUnitId +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.ModuleName (ModuleName) +import Distribution.Package +import Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths +import Distribution.Simple.CCompiler +import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.LocalBuildInfo +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PreProcess.Types +import Distribution.Simple.PreProcess.Unlit +import Distribution.Simple.Program +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Test.LibV09 +import Distribution.Simple.Utils +import Distribution.System +import Distribution.Types.PackageName.Magic +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +import System.Directory (doesDirectoryExist, doesFileExist) +import System.FilePath + ( normalise + , replaceExtension + , splitExtension + , takeDirectory + , takeExtensions + ) +import System.Info (arch, os) + +-- | Just present the modules in the order given; this is the default and it is +-- appropriate for preprocessors which do not have any sort of dependencies +-- between modules. +unsorted + :: Verbosity + -> [path] + -> [ModuleName] + -> IO [ModuleName] +unsorted _ _ ms = pure ms + +-- | Function to determine paths to possible extra C sources for a +-- preprocessor: just takes the path to the build directory and uses +-- this to search for C sources with names that match the +-- preprocessor's output name format. +type PreProcessorExtras = + Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir Source) + -> IO [RelativePath Source File] + +mkSimplePreProcessor + :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) + -> Verbosity + -> IO () +mkSimplePreProcessor + simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity = simplePP inFile outFile verbosity + where + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor + :: PreProcessor + -> FilePath + -> FilePath + -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- | A preprocessor for turning non-Haskell files with the given 'Suffix' +-- (i.e. file extension) into plain Haskell source files. +type PPSuffixHandler = + (Suffix, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +-- +-- XXX: This is terrible +preprocessComponent + :: PackageDescription + -> Component + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers = + -- Skip preprocessing for scripts since they should be regular Haskell files, + -- but may have no or unknown extensions. + when (package pd /= fakePackageId) $ do + -- NB: never report instantiation here; we'll report it properly when + -- building. + setupMessage' + verbosity + "Preprocessing" + (packageId pd) + (componentLocalName clbi) + (Nothing :: Maybe [(ModuleName, Module)]) + case comp of + (CLib lib@Library{libBuildInfo = bi}) -> do + let dirs = + hsSourceDirs bi + ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs (componentBuildDir lbi clbi) hndlrs + (CFLib flib@ForeignLib{foreignLibBuildInfo = bi}) -> do + let flibDir = flibBuildDir lbi flib + dirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs flibDir hndlrs + (CExe exe@Executable{buildInfo = bi}) -> do + let exeDir = exeBuildDir lbi exe + dirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + let hndlrs = localHandlers bi + mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi) + for_ (map moduleNameSymbolicPath mods) $ + pre dirs exeDir hndlrs + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensionsSymbolicPath (modulePath exe) + CTest test@TestSuite{} -> do + let testDir = testBuildDir lbi test + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f testDir + TestSuiteLibV09 _ _ -> do + writeSimpleTestStub test (i testDir) + preProcessTest test (makeRelativePathEx $ stubFilePath test) testDir + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingTest tt + CBench bm@Benchmark{} -> do + let benchDir = benchmarkBuildDir lbi bm + case benchmarkInterface bm of + BenchmarkExeV10 _ f -> + preProcessBench bm f benchDir + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportForPreProcessingBenchmark tt + where + orderingFromHandlers v d hndlrs mods = + foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs + builtinCSuffixes = map Suffix cSourceExtensions + builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes + localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers] + mbWorkDir = mbWorkDirLBI lbi + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + pre dirs dir lhndlrs fp = + preprocessFile mbWorkDir dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs True + preProcessTest test = + preProcessComponent + (testBuildInfo test) + (testModules test) + preProcessBench bm = + preProcessComponent + (benchmarkBuildInfo bm) + (benchmarkModules bm) + + preProcessComponent + :: BuildInfo + -> [ModuleName] + -> RelativePath Source File + -> SymbolicPath Pkg (Dir Build) + -> IO () + preProcessComponent bi modules exePath outputDir = do + let biHandlers = localHandlers bi + sourceDirs = + hsSourceDirs bi + ++ [ autogenComponentModulesDir lbi clbi + , autogenPackageModulesDir lbi + ] + sequence_ + [ preprocessFile + mbWorkDir + sourceDirs + outputDir + isSrcDist + (moduleNameSymbolicPath modu) + verbosity + builtinSuffixes + biHandlers + False + | modu <- modules + ] + -- Note we don't fail on missing in this case, because the main file + -- may be generated later (i.e. by a test code generator) + preprocessFile + mbWorkDir + (coerceSymbolicPath outputDir : hsSourceDirs bi) + outputDir + isSrcDist + (dropExtensionsSymbolicPath $ exePath) + verbosity + builtinSuffixes + biHandlers + False + +-- TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- | Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ package directory location + -> [SymbolicPath Pkg (Dir Source)] + -- ^ source directories + -> SymbolicPath Pkg (Dir Build) + -- ^ build directory + -> Bool + -- ^ preprocess for sdist + -> RelativePath Source File + -- ^ module file name + -> Verbosity + -- ^ verbosity + -> [Suffix] + -- ^ builtin suffixes + -> [(Suffix, PreProcessor)] + -- ^ possible preprocessors + -> Bool + -- ^ fail on missing file + -> IO () +preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + + -- Note [Dodgy build dirs for preprocessors] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- By looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile + case (bsrcFiles, failOnMissing) of + (Nothing, True) -> + dieWithException verbosity $ + CantFindSourceForPreProcessFile $ + "can't find source for " + ++ getSymbolicPath baseFile + ++ " in " + ++ intercalate ", " (map getSymbolicPath searchLoc) + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = + fromMaybe + (error "Distribution.Simple.PreProcess: Just expected") + (lookup (Suffix $ safeTail ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + -- TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> + i psrcFile `moreRecentFile` i ppsrcFile + when recomp $ do + let destDir = i buildLoc takeDirectory srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack + pp + (psrcLoc, getSymbolicPath $ psrcRelFile) + (buildLoc, srcStem <.> "hs") + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + buildAsSrcLoc :: SymbolicPath Pkg (Dir Source) + buildAsSrcLoc = coerceSymbolicPath buildLoc + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack + pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + -- Preprocessors are expected to take into account the working + -- directory, e.g. using runProgramCwd with a working directory + -- computed with mbWorkDirLBI. + -- Hence the use of 'getSymbolicPath' here. + runPreProcessor + pp + (getSymbolicPath $ inBaseDir, inRelativeFile) + (getSymbolicPath $ outBaseDir, outRelativeFile) + verbosity + + -- Here we interact directly with the file system, so we must + -- interpret symbolic paths with respect to the working directory. + let + inFile = normalise (i inBaseDir inRelativeFile) + outFile = normalise (i outBaseDir outRelativeFile) + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + +-- ------------------------------------------------------------ + +-- * known preprocessors + +-- ------------------------------------------------------------ + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor + { platformIndependent = True + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) (dieWithException verbosity) (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi clbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi + GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi + _ -> ppCpphs args bi lbi clbi + where + cppArgs = getCppOptions bi lbi + args = cppArgs ++ extraArgs + +ppGhcCpp + :: Program + -> (Version -> Bool) + -> [String] + -> BuildInfo + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> PreProcessor +ppGhcCpp program xHs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (prog, version, _) <- + requireProgramVersion + verbosity + program + anyVersion + (withPrograms lbi) + runProgramCwd verbosity (mbWorkDirLBI lbi) prog $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if xHs version then ["-x", "hs"] else []) + ++ ["-optP-include", "-optP" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- + requireProgramVersion + verbosity + cpphsProgram + anyVersion + (withPrograms lbi) + runProgramCwd verbosity (mbWorkDirLBI lbi) cpphsProg $ + ("-O" ++ outFile) + : inFile + : "--noline" + : "--strip" + : ( if cpphsVersion >= mkVersion [1, 6] + then ["--include=" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + else [] + ) + ++ extraArgs + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + (hsc2hsProg, hsc2hsVersion, _) <- + requireProgramVersion + verbosity + hsc2hsProgram + anyVersion + (withPrograms lbi) + let runHsc2hs = runProgramCwd verbosity mbWorkDir hsc2hsProg + -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122. + let isCross = hostPlatform lbi /= buildPlatform + prependCrossFlags = if isCross then ("-x" :) else id + let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4] + pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile + if hsc2hsSupportsResponseFiles + then + withResponseFile + verbosity + defaultTempFileOptions + "hsc2hs-response.txt" + Nothing + pureArgs + ( \responseFileName -> + runHsc2hs (prependCrossFlags ["@" ++ responseFileName]) + ) + else runHsc2hs (prependCrossFlags pureArgs) + } + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPathX allowAbs Pkg to -> FilePath + u = interpretSymbolicPathCWD + mbWorkDir = mbWorkDirLBI lbi + + -- Returns a list of command line arguments that can either be passed + -- directly, or via a response file. + genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String] + genPureArgs hsc2hsVersion gccProg inFile outFile = + -- Additional gcc options + [ "--cflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + ++ [ "--lflag=" ++ opt + | opt <- + programDefaultArgs gccProg + ++ programOverrideArgs gccProg + ] + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] + ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- map getSymbolicPath (PD.frameworks bi) ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] + ] + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ ["--cflag=" ++ opt | opt <- platformDefines lbi] + -- Options from the current package: + ++ ["--cflag=-I" ++ u dir | dir <- PD.includeDirs bi] + ++ [ "--cflag=-I" ++ u (buildDir lbi unsafeCoerceSymbolicPath relDir) + | relDir <- mapMaybe symbolicPathRelative_maybe $ PD.includeDirs bi + ] + ++ [ "--cflag=" ++ opt + | opt <- + PD.ccOptions bi + ++ PD.cppOptions bi + -- hsc2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- DO NOT add PD.cxxOptions unless this changes! + ] + ++ [ "--cflag=" ++ opt + | opt <- + [ "-I" ++ u (autogenComponentModulesDir lbi clbi) + , "-I" ++ u (autogenPackageModulesDir lbi) + , "-include" + , u $ autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName + ] + ] + ++ [ "--lflag=-L" ++ u opt + | opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ [ "--lflag=-Wl,-R," ++ u opt + | isELF + , opt <- + if withFullyStaticExe lbi + then PD.extraLibDirsStatic bi + else PD.extraLibDirs bi + ] + ++ ["--lflag=-l" ++ opt | opt <- PD.extraLibs bi] + ++ ["--lflag=" ++ opt | opt <- PD.ldOptions bi] + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ Installed.ccOptions pkg + ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- + ["-L" ++ opt | opt <- Installed.libraryDirs pkg] + ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg + ] + ++ [ "-l" ++ opt + | opt <- + if withFullyStaticExe lbi + then Installed.extraLibrariesStatic pkg + else Installed.extraLibraries pkg + ] + ++ Installed.ldOptions pkg + ] + ++ preccldFlags + ++ hsc2hsOptions bi + ++ postccldFlags + ++ ["-o", outFile, inFile] + where + -- hsc2hs flag parsing was wrong + -- (see -- https://github.com/haskell/hsc2hs/issues/35) + -- so we need to put -- --cc/--ld *after* hsc2hsOptions, + -- for older hsc2hs (pre 0.68.8) so that they can be overridden. + ccldFlags = + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg + ] + + (preccldFlags, postccldFlags) + | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, []) + | otherwise = ([], ccldFlags) + + hacked_index = packageHacks (installedPkgs lbi) + -- Look only at the dependencies of the current component + -- being built! This relies on 'installedPkgs' maintaining + -- 'InstalledPackageInfo' for internal deps too; see #2971. + pkgs = PackageIndex.topologicalOrder $ + case PackageIndex.dependencyClosure + hacked_index + (map fst (componentPackageDeps clbi)) of + Left index' -> index' + Right inf -> + error ("ppHsc2hs: broken closure: " ++ show inf) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + GHCJS -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (mkPackageName "rts") of + [(_, [rts])] -> + PackageIndex.insert rts{Installed.ldOptions = []} index + _ -> error "No (or multiple) ghc rts package is registered!!" + +ppHsc2hsExtras :: PreProcessorExtras +ppHsc2hsExtras mbWorkDir buildBaseDir = do + fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir + let hscCFiles = filter ("_hsc.c" `isSuffixOf`) fs + return $ map makeRelativePathEx hscCFiles + +ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppC2hs bi lbi clbi = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = + \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) + verbosity -> do + (c2hsProg, _, _) <- + requireProgramVersion + verbosity + c2hsProgram + (orLaterVersion (mkVersion [0, 15])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + runProgramCwd verbosity mbWorkDir c2hsProg $ + -- Options from the current package: + ["--cpp=" ++ programPath gccProg, "--cppopts=-E"] + ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi] + ++ ["--cppopts=-include" ++ u (autogenComponentModulesDir lbi clbi makeRelativePathEx cppHeaderName)] + ++ ["--include=" ++ outBaseDir] + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- + ["-I" ++ opt | opt <- Installed.includeDirs pkg] + ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg, + -- c2hs uses the C ABI + -- We assume that there are only C sources + -- and C++ functions are exported via a C + -- interface and wrapped in a C source file. + -- Therefore we do not supply C++ flags + -- because there will not be C++ sources. + -- + -- + -- DO NOT add Installed.cxxOptions unless this changes! + c `elem` "DIU" + ] + ] + -- TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile + ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + mbWorkDir = mbWorkDirLBI lbi + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + +ppC2hsExtras :: PreProcessorExtras +ppC2hsExtras mbWorkDir buildBaseDir = do + fs <- getDirectoryContentsRecursive $ interpretSymbolicPath mbWorkDir buildBaseDir + return $ + map makeRelativePathEx $ + filter (\p -> takeExtensions p == ".chs.c") fs + +-- TODO: perhaps use this with hsc2hs too +-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC +-- instead of combining all these cases in a single function. This blind combination can +-- potentially lead to compilation inconsistencies. +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi = + platformDefines lbi + ++ cppOptions bi + ++ ["-I" ++ getSymbolicPath dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"] + +platformDefines :: LocalBuildInfo -> [String] +platformDefines lbi = + case compilerFlavor comp of + GHC -> + ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + GHCJS -> + compatGlasgowHaskell + ++ ["-D__GHCJS__=" ++ versionInt version] + ++ ["-D" ++ os ++ "_BUILD_OS=1"] + ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"] + ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr + ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr + _ -> [] + where + comp = compiler lbi + Platform hostArch hostOS = hostPlatform lbi + version = compilerVersion comp + compatGlasgowHaskell = + maybe + [] + (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v]) + (compilerCompatVersion GHC comp) + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt v = case versionNumbers v of + [] -> "1" + [n] -> show n + n1 : n2 : _ -> + -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + + osStr = case hostOS of + Linux -> ["linux"] + Windows -> ["mingw32"] + OSX -> ["darwin"] + FreeBSD -> ["freebsd"] + OpenBSD -> ["openbsd"] + NetBSD -> ["netbsd"] + DragonFly -> ["dragonfly"] + Solaris -> ["solaris2"] + AIX -> ["aix"] + HPUX -> ["hpux"] + IRIX -> ["irix"] + HaLVM -> [] + IOS -> ["ios"] + Android -> ["android"] + Ghcjs -> ["ghcjs"] + Wasi -> ["wasi"] + Hurd -> ["hurd"] + Haiku -> ["haiku"] + OtherOS _ -> [] + archStr = case hostArch of + I386 -> ["i386"] + X86_64 -> ["x86_64"] + PPC -> ["powerpc"] + PPC64 -> ["powerpc64"] + PPC64LE -> ["powerpc64le"] + Sparc -> ["sparc"] + Sparc64 -> ["sparc64"] + Arm -> ["arm"] + AArch64 -> ["aarch64"] + Mips -> ["mips"] + SH -> [] + IA64 -> ["ia64"] + S390 -> ["s390"] + S390X -> ["s390x"] + Alpha -> ["alpha"] + Hppa -> ["hppa"] + Rs6000 -> ["rs6000"] + M68k -> ["m68k"] + Vax -> ["vax"] + RISCV64 -> ["riscv64"] + LoongArch64 -> ["loongarch64"] + JavaScript -> ["javascript"] + Wasm32 -> ["wasm32"] + OtherArch _ -> [] + +ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppHappy _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags GHCJS = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor +ppAlex _ lbi _ = pp{platformIndependent = True} + where + pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags GHCJS = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor + { platformIndependent = False + , ppOrdering = unsorted + , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + runDbProgramCwd + verbosity + (mbWorkDirLBI lbi) + prog + (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- | Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [PPSuffixHandler] -> [Suffix] +ppSuffixes = map fst + +-- | Standard preprocessors: c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [PPSuffixHandler] +knownSuffixHandlers = + [ (Suffix "chs", ppC2hs) + , (Suffix "hsc", ppHsc2hs) + , (Suffix "x", ppAlex) + , (Suffix "y", ppHappy) + , (Suffix "ly", ppHappy) + , (Suffix "cpphs", ppCpp) + ] + +-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs. +knownExtrasHandlers :: [PreProcessorExtras] +knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras] + +-- | Find any extra C sources generated by preprocessing that need to +-- be added to the component (addresses issue #238). +preprocessExtras + :: Verbosity + -> Component + -> LocalBuildInfo + -> IO [SymbolicPath Pkg File] +preprocessExtras verbosity comp lbi = case comp of + CLib _ -> pp $ buildDir lbi + (CExe exe@Executable{}) -> pp $ exeBuildDir lbi exe + (CFLib flib@ForeignLib{}) -> pp $ flibBuildDir lbi flib + CTest test -> + case testInterface test of + TestSuiteUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingTestExtras tt + _ -> pp $ testBuildDir lbi test + CBench bm -> + case benchmarkInterface bm of + BenchmarkUnsupported tt -> + dieWithException verbosity $ NoSupportPreProcessingBenchmarkExtras tt + _ -> pp $ benchmarkBuildDir lbi bm + where + pp :: SymbolicPath Pkg (Dir Build) -> IO [SymbolicPath Pkg File] + pp builddir = do + -- Use the build dir as a source dir. + let dir :: SymbolicPath Pkg (Dir Source) + dir = coerceSymbolicPath builddir + mbWorkDir = mbWorkDirLBI lbi + b <- doesDirectoryExist (interpretSymbolicPathLBI lbi dir) + if b + then do + xs <- for knownExtrasHandlers $ withLexicalCallStack $ \f -> f mbWorkDir dir + let not_subs = + map (dir ) $ + filter (not_sub . getSymbolicPath) $ + concat xs + return not_subs + else pure [] + -- TODO: This is a terrible hack to work around #3545 while we don't + -- reorganize the directory layout. Basically, for the main + -- library, we might accidentally pick up autogenerated sources for + -- our subcomponents, because they are all stored as subdirectories + -- in dist/build. This is a cheap and cheerful check to prevent + -- this from happening. It is not particularly correct; for example + -- if a user has a test suite named foobar and puts their C file in + -- foobar/foo.c, this test will incorrectly exclude it. But I + -- didn't want to break BC... + not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs] + component_dirs = component_names (localPkgDescr lbi) + -- TODO: libify me + component_names pkg_descr = + fmap unUnqualComponentName $ + mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) + ++ map exeName (executables pkg_descr) + ++ map testName (testSuites pkg_descr) + ++ map benchmarkName (benchmarks pkg_descr) diff --git a/src/Distribution/Simple/PreProcess/Types.hs b/src/Distribution/Simple/PreProcess/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/PreProcess/Types.hs @@ -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"] diff --git a/src/Distribution/Simple/PreProcess/Unlit.hs b/src/Distribution/Simple/PreProcess/Unlit.hs --- a/src/Distribution/Simple/PreProcess/Unlit.hs +++ b/src/Distribution/Simple/PreProcess/Unlit.hs @@ -1,4 +1,9 @@ ----------------------------------------------------------------------------- + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + -- | -- Module : Distribution.Simple.PreProcess.Unlit -- Copyright : ... @@ -8,73 +13,77 @@ -- -- Remove the \"literal\" markups from a Haskell source file, including -- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.Generic (safeTail, safeLast, safeInit) +module Distribution.Simple.PreProcess.Unlit (unlit, plain) where import Data.List (mapAccumL) +import Distribution.Compat.Prelude +import Distribution.Simple.Errors +import Distribution.Utils.Generic (safeInit, safeLast, safeTail) +import Prelude () -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String +data Classified + = BirdTrack String + | Blank String + | Ordinary String + | Line !Int String + | CPP String + | BeginCode + | EndCode + | -- output only: + Error String + | Comment String -- | No unliteration. plain :: String -> String -> String plain _ hs = hs classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file@('"':_:_):_) | all isDigit line - && safeLast file == Just '"' - -- this shouldn't fail as we tested for 'all isDigit' - -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) +classify ('>' : s) = BirdTrack s +classify ('#' : s) = case tokens s of + (line : file@('"' : _ : _) : _) + | all isDigit line + && safeLast file == Just '"' -> + -- this shouldn't fail as we tested for 'all isDigit' + Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse + _ -> CPP s + where + tokens = unfoldr $ \str -> case lex str of + (t@(_ : _), str') : _ -> Just (t, str') + _ -> Nothing +classify ('\\' : s) | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s -- So the weird exception for comment indenting is to make things work with -- haddock, see classifyAndCheckForBirdTracks below. unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError +unclassify _ (BirdTrack s) = ' ' : s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#' : s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError -- | 'unlit' takes a filename (for error reports), and transforms the -- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String +unlit :: FilePath -> String -> Either String CabalException unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - + let (usesBirdTracks, classified) = + classifyAndCheckForBirdTracks + . inlines + $ input + in either + (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified where -- So haddock requires comments and code to align, since it treats comments -- as following the layout rule. This is a pain for us since bird track @@ -94,16 +103,17 @@ in (seenBirdTrack || isBirdTrack classification, classification) isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False + isBirdTrack _ = False - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls + checkErrors ls = case [e | Error e <- ls] of + [] -> Left ls + (message : _) -> Right (UnlitException (f ++ ":" ++ show n ++ ": " ++ message)) + where + (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _ : _) = (f, n) + errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls + errorPos f n (_ : ls) = errorPos f (n + 1) ls -- Here we model a state machine, with each state represented by -- a local function. We only have four states (well, five, @@ -117,51 +127,51 @@ reclassify :: [Classified] -> [Classified] reclassify = blank -- begin in blank state where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls + latex [] = [] + latex (EndCode : ls) = Blank "" : comment ls + latex (BeginCode : _) = [Error "\\begin{code} in code section"] + latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls + latex (l : ls) = l : latex ls - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls + blank [] = [] + blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode : ls) = Blank "" : latex ls + blank (BirdTrack l : ls) = BirdTrack l : bird ls + blank (Ordinary l : ls) = Comment l : comment ls + blank (l : ls) = l : blank ls - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls + bird [] = [] + bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode : ls) = Blank "" : latex ls + bird (Blank l : ls) = Blank l : blank ls + bird (Ordinary _ : _) = [Error "program line before comment line"] + bird (l : ls) = l : bird ls - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] + comment [] = [] + comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode : ls) = Blank "" : latex ls + comment (CPP l : ls) = CPP l : comment ls + comment (BirdTrack _ : _) = [Error "comment line before program line"] -- a blank line and another ordinary line following a comment -- will be treated as continuing the comment. Otherwise it's -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError + comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls + comment (Blank l : ls) = Blank l : blank ls + comment (Line n f : ls) = Line n f : comment ls + comment (Ordinary l : ls) = Comment l : comment ls + comment (Comment _ : _) = internalError + comment (Error _ : _) = internalError -- Re-implementation of 'lines', for better efficiency (but decreased laziness). -- Also, importantly, accepts non-standard DOS and Mac line ending characters. inlines :: String -> [String] inlines xs = lines' xs id where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) + lines' [] acc = [acc []] + lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS + lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS + lines' ('\n' : s) acc = acc [] : lines' s id -- Unix + lines' (c : s) acc = lines' s (acc . (c :)) internalError :: a internalError = error "unlit: internal error" diff --git a/src/Distribution/Simple/Program.hs b/src/Distribution/Simple/Program.hs --- a/src/Distribution/Simple/Program.hs +++ b/src/Distribution/Simple/Program.hs @@ -1,7 +1,16 @@ +{- FUTUREWORK: + - + - Currently the logic in this module is not tested. + - + - Ideally, a set of unit tests that check whether certain + - flags trigger recompilation should be added. + - -} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -34,150 +43,209 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , ProgramSearchPath - , ProgramSearchPathEntry(..) - , simpleProgram - , findProgramOnSearchPath - , defaultProgramSearchPath - , findProgramVersion +module Distribution.Simple.Program + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) + , simpleProgram + , findProgramOnSearchPath + , defaultProgramSearchPath + , findProgramVersion -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - , suppressOverrideArgs + , ConfiguredProgram (..) + , programPath + , ProgArg + , ProgramLocation (..) + , runProgram + , runProgramCwd + , getProgramOutput + , suppressOverrideArgs -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - , getProgramInvocationLBS + , ProgramInvocation (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS -- * The collection of unconfigured and configured programs - , builtinPrograms + , builtinPrograms -- * The collection of configured programs we can run - , ProgramDb - , defaultProgramDb - , emptyProgramDb - , restoreProgramDb - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , getProgramSearchPath - , setProgramSearchPath - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , lookupProgramVersion - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , needProgram - , runDbProgram - , getDbProgramOutput + , ProgramDb + , defaultProgramDb + , emptyProgramDb + , restoreProgramDb + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramVersion + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + , runDbProgram + , runDbProgramCwd + , getDbProgramOutput + , getDbProgramOutputCwd -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , gccProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , doctestProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - , hpcProgram - ) where + , ghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , gccProgram + , gppProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db +import Distribution.Simple.Errors import Distribution.Simple.Program.Builtin +import Distribution.Simple.Program.Db import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types import Distribution.Simple.Utils +import Distribution.Utils.Path import Distribution.Verbosity -- | Runs the given configured program. -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () +runProgram + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () runProgram verbosity prog args = runProgramInvocation verbosity (programInvocation prog args) +-- | Runs the given configured program. +runProgramCwd + :: Verbosity + -- ^ Verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ Working directory + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runProgramCwd verbosity mbWorkDir prog args = + runProgramInvocation verbosity (programInvocationCwd mbWorkDir prog args) -- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String +getProgramOutput + :: Verbosity + -- ^ Verbosity + -> ConfiguredProgram + -- ^ The program to run + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String getProgramOutput verbosity prog args = getProgramInvocationOutput verbosity (programInvocation prog args) +-- | Looks up the given program in the program database and runs it. +runDbProgram + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog progDb args = + runDbProgramCwd verbosity Nothing prog progDb args -- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runDbProgram verbosity prog programDb args = +runDbProgramCwd + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ working directory + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO () +runDbProgramCwd verbosity mbWorkDir prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound - Just configuredProg -> runProgram verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" + Nothing -> + dieWithException verbosity $ ProgramNotFound (programName prog) + Just configuredProg -> runProgramCwd verbosity mbWorkDir configuredProg args -- | Looks up the given program in the program database and runs it. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getDbProgramOutput verbosity prog programDb args = +getDbProgramOutput + :: Verbosity + -- ^ verbosity + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String +getDbProgramOutput verb prog progDb args = + getDbProgramOutputCwd verb Nothing prog progDb args + +-- | Looks up the given program in the program database and runs it. +getDbProgramOutputCwd + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir to)) + -- ^ working directory + -> Program + -- ^ The program to run + -> ProgramDb + -- ^ look up the program here + -> [ProgArg] + -- ^ Any /extra/ arguments to add + -> IO String +getDbProgramOutputCwd verbosity mbWorkDir prog programDb args = case lookupProgram prog programDb of - Nothing -> die' verbosity notFound - Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program '" ++ programName prog - ++ "' is required but it could not be found" + Nothing -> dieWithException verbosity $ ProgramNotFound (programName prog) + Just configuredProg -> + getProgramInvocationOutput verbosity $ + programInvocationCwd mbWorkDir configuredProg args diff --git a/src/Distribution/Simple/Program/Ar.hs b/src/Distribution/Simple/Program/Ar.hs --- a/src/Distribution/Simple/Program/Ar.hs +++ b/src/Distribution/Simple/Program/Ar.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NondecreasingIndentation #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ar -- Copyright : Duncan Coutts 2009 @@ -12,115 +14,163 @@ -- Portability : portable -- -- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation +module Distribution.Simple.Program.Ar + ( createArLibArchive + , multiStageProgramInvocation ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Distribution.Compat.CopyFile (filesEqual) -import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program - ( ProgramInvocation, arProgram, requireProgram ) + ( ProgramInvocation + , arProgram + , requireProgram + ) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) + ( multiStageProgramInvocation + , programInvocationCwd + , runProgramInvocation + ) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions, dieWithLocation', withTempDirectory ) + ( defaultTempFileOptions + , dieWithLocation' + , withTempDirectoryCwd + ) import Distribution.System - ( Arch(..), OS(..), Platform(..) ) + ( Arch (..) + , OS (..) + , Platform (..) + ) +import Distribution.Utils.Path import Distribution.Verbosity - ( Verbosity, deafening, verbose ) + ( Verbosity + , deafening + , verbose + ) + import System.Directory (doesFileExist, renameFile) -import System.FilePath ((), splitFileName) +import System.FilePath (splitFileName) import System.IO - ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek) - , hFileSize, hSeek, withBinaryFile ) + ( Handle + , IOMode (ReadWriteMode) + , SeekMode (AbsoluteSeek) + , hFileSize + , hSeek + , withBinaryFile + ) -- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> LocalBuildInfo - -> FilePath -> [FilePath] -> IO () +createArLibArchive + :: Verbosity + -> LocalBuildInfo + -> SymbolicPath Pkg File + -> [SymbolicPath Pkg File] + -> IO () createArLibArchive verbosity lbi targetPath files = do - (ar, _) <- requireProgram verbosity arProgram progDb - - let (targetDir, targetName) = splitFileName targetPath - withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do - let tmpPath = tmpDir targetName + (arProg, _) <- requireProgram verbosity arProgram progDb - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- When we need to call ar multiple times we use "ar q" and for the last - -- call on OSX we use "ar qs" so that it'll make the index. + let (targetDir0, targetName0) = splitFileName $ getSymbolicPath targetPath + targetDir = makeSymbolicPath targetDir0 + targetName = makeRelativePathEx targetName0 + mbWorkDir = mbWorkDirLBI lbi + -- See Note [Symbolic paths] in Distribution.Utils.Path + i = interpretSymbolicPath mbWorkDir + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + withTempDirectoryCwd verbosity mbWorkDir targetDir "objs" $ \tmpDir -> do + let tmpPath = tmpDir targetName - let simpleArgs = case hostOS of - OSX -> ["-r", "-s"] - _ -> ["-r"] + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier + -- in "q" mode which compels the archiver to add the members of an input + -- archive to the output, rather than the archive itself. This is + -- necessary as GHC may produce .o files that are actually archives. See + -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. - initialArgs = ["-q"] - finalArgs = case hostOS of - OSX -> ["-q", "-s"] - _ -> ["-q"] + let simpleArgs, initialArgs, finalArgs :: [String] + simpleArgs = case hostOS of + OSX -> ["-r", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-r"] - extraArgs = verbosityOpts verbosity ++ [tmpPath] + initialArgs = ["-q"] + finalArgs = case hostOS of + OSX -> ["-q", "-s"] + _ | dashLSupported -> ["-qL"] + _ -> ["-q"] - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) + extraArgs = verbosityOpts verbosity ++ [u tmpPath] - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) + ar = programInvocationCwd mbWorkDir arProg + simple = ar (simpleArgs ++ extraArgs) + initial = ar (initialArgs ++ extraArgs) + middle = initial + final = ar (finalArgs ++ extraArgs) - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ar $ - simpleArgs ++ extraArgs ++ ['@' : atFile] + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) + dashLSupported = + arDashLSupported (compiler lbi) - if oldVersionManualOverride || responseArgumentsNotSupported - then - sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - else - withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + (ar $ simpleArgs ++ extraArgs ++ ['@' : atFile]) - unless (hostArch == Arm -- See #1537 - || hostOS == AIX) $ -- AIX uses its own "ar" format variant - wipeMetadata verbosity tmpPath - equal <- filesEqual tmpPath targetPath - unless equal $ renameFile tmpPath targetPath + if oldVersionManualOverride || responseArgumentsNotSupported + then + sequence_ + [ runProgramInvocation verbosity inv + | inv <- + multiStageProgramInvocation + simple + (initial, middle, final) + (map getSymbolicPath files) + ] + else withResponseFile verbosity defaultTempFileOptions "ar.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path + unless + ( hostArch == Arm -- See #1537 + || hostOS == AIX + ) + $ wipeMetadata verbosity (i tmpPath) -- AIX uses its own "ar" format variant + equal <- filesEqual (i tmpPath) (i targetPath) + unless equal $ renameFile (i tmpPath) (i targetPath) where progDb = withPrograms lbi Platform hostArch hostOS = hostPlatform lbi verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] -- Do not warn if library had to be created. + | v >= verbose = [] + | otherwise = ["-c"] -- Do not warn if library had to be created. -- | @ar@ by default includes various metadata for each object file in their -- respective headers, so the output can differ for the same inputs, making @@ -130,17 +180,18 @@ -- rather harder than just re-implementing this feature. wipeMetadata :: Verbosity -> FilePath -> IO () wipeMetadata verbosity path = do - -- Check for existence first (ReadWriteMode would create one otherwise) - exists <- doesFileExist path - unless exists $ wipeError "Temporary file disappeared" - withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h - + -- Check for existence first (ReadWriteMode would create one otherwise) + exists <- doesFileExist path + unless exists $ wipeError "Temporary file disappeared" + withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h where - wipeError msg = dieWithLocation' verbosity path Nothing $ + wipeError msg = + dieWithLocation' verbosity path Nothing $ "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg archLF = "!\x0a" -- global magic, 8 bytes x60LF = "\x60\x0a" -- header magic, 2 bytes - metadata = BS.concat + metadata = + BS.concat [ "0 " -- mtime, 12 bytes , "0 " -- UID, 6 bytes , "0 " -- GID, 6 bytes @@ -152,40 +203,41 @@ -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details wipeArchive :: Handle -> Integer -> IO () wipeArchive h archiveSize = do - global <- BS.hGet h (BS.length archLF) - unless (global == archLF) $ wipeError "Bad global header" - wipeHeader (toInteger $ BS.length archLF) - + global <- BS.hGet h (BS.length archLF) + unless (global == archLF) $ wipeError "Bad global header" + wipeHeader (toInteger $ BS.length archLF) where wipeHeader :: Integer -> IO () wipeHeader offset = case compare offset archiveSize of - EQ -> return () - GT -> wipeError (atOffset "Archive truncated") - LT -> do - header <- BS.hGet h headerSize - unless (BS.length header == headerSize) $ - wipeError (atOffset "Short header") - let magic = BS.drop 58 header - unless (magic == x60LF) . wipeError . atOffset $ - "Bad magic " ++ show magic ++ " in header" - - let name = BS.take 16 header - let size = BS.take 10 $ BS.drop 48 header - objSize <- case reads (BS8.unpack size) of - [(n, s)] | all isSpace s -> return n - _ -> wipeError (atOffset "Bad file size in header") + EQ -> return () + GT -> wipeError (atOffset "Archive truncated") + LT -> do + header <- BS.hGet h headerSize + unless (BS.length header == headerSize) $ + wipeError (atOffset "Short header") + let magic = BS.drop 58 header + unless (magic == x60LF) . wipeError . atOffset $ + "Bad magic " ++ show magic ++ " in header" - let replacement = BS.concat [ name, metadata, size, magic ] - unless (BS.length replacement == headerSize) $ - wipeError (atOffset "Something has gone terribly wrong") - hSeek h AbsoluteSeek offset - BS.hPut h replacement + let name = BS.take 16 header + let size = BS.take 10 $ BS.drop 48 header + objSize <- case reads (BS8.unpack size) of + [(n, s)] | all isSpace s -> return n + _ -> wipeError (atOffset "Bad file size in header") - let nextHeader = offset + toInteger headerSize + - -- Odd objects are padded with an extra '\x0a' - if odd objSize then objSize + 1 else objSize - hSeek h AbsoluteSeek nextHeader - wipeHeader nextHeader + let replacement = BS.concat [name, metadata, size, magic] + unless (BS.length replacement == headerSize) $ + wipeError (atOffset "Something has gone terribly wrong") + hSeek h AbsoluteSeek offset + BS.hPut h replacement + let nextHeader = + offset + + toInteger headerSize + + + -- Odd objects are padded with an extra '\x0a' + if odd objSize then objSize + 1 else objSize + hSeek h AbsoluteSeek nextHeader + wipeHeader nextHeader where atOffset msg = msg ++ " at offset " ++ show offset diff --git a/src/Distribution/Simple/Program/Builtin.hs b/src/Distribution/Simple/Program/Builtin.hs --- a/src/Distribution/Simple/Program/Builtin.hs +++ b/src/Distribution/Simple/Program/Builtin.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Builtin -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -9,47 +10,42 @@ -- The module defines all the known built-in 'Program's. -- -- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured programs - builtinPrograms, +module Distribution.Simple.Program.Builtin + ( -- * The collection of unconfigured and configured programs + builtinPrograms -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - runghcProgram, - ghcjsProgram, - ghcjsPkgProgram, - hmakeProgram, - jhcProgram, - haskellSuiteProgram, - haskellSuitePkgProgram, - uhcProgram, - gccProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - doctestProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - hpcProgram, + , ghcProgram + , ghcPkgProgram + , runghcProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , gccProgram + , gppProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , doctestProgram + , haddockProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + , hpcProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Find +import Distribution.Simple.Program.GHC import Distribution.Simple.Program.Internal import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types @@ -60,289 +56,331 @@ import qualified Data.Map as Map -- ------------------------------------------------------------ + -- * Known programs + -- ------------------------------------------------------------ -- | The default list of programs. -- These programs are typically used internally to Cabal. builtinPrograms :: [Program] builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , runghcProgram - , ghcPkgProgram - , ghcjsProgram - , ghcjsPkgProgram - , haskellSuiteProgram - , haskellSuitePkgProgram - , hmakeProgram - , jhcProgram - , uhcProgram - , hpcProgram - -- preprocessors - , hscolourProgram - , doctestProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] + [ -- compilers and related progs + ghcProgram + , runghcProgram + , ghcPkgProgram + , ghcjsProgram + , ghcjsPkgProgram + , jhcProgram + , uhcProgram + , hpcProgram + , -- preprocessors + hscolourProgram + , doctestProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , -- platform toolchain + gccProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + , -- configuration tools + pkgConfigProgram + ] ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id, +ghcProgram = + (simpleProgram "ghc") + { programFindVersion = findProgramVersion "--numeric-version" id + , programPostConf = ghcPostConf + , programNormaliseArgs = normaliseGhcArgs + } + where + ghcPostConf _verbosity ghcProg = do + let setLanguageEnv prog = + prog + { programOverrideEnv = + ("LANGUAGE", Just "en") + : programOverrideEnv ghcProg + } - -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 - -- (spurious warning on non-english locales) - programPostConf = \_verbosity ghcProg -> - do let ghcProg' = ghcProg { - programOverrideEnv = ("LANGUAGE", Just "en") - : programOverrideEnv ghcProg - } - -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. - affectedVersionRange = intersectVersionRanges - (laterVersion $ mkVersion [7,8,0]) - (earlierVersion $ mkVersion [7,8,4]) - return $ maybe ghcProg - (\v -> if withinRange v affectedVersionRange - then ghcProg' else ghcProg) - (programVersion ghcProg), + ignorePackageEnv prog = prog{programDefaultArgs = "-package-env=-" : programDefaultArgs prog} - programNormaliseArgs = normaliseGhcArgs - } + -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4. + affectedVersionRange = + intersectVersionRanges + (laterVersion $ mkVersion [7, 8, 0]) + (earlierVersion $ mkVersion [7, 8, 4]) + canIgnorePackageEnv = orLaterVersion $ mkVersion [8, 4, 4] + + applyWhen cond f prog = if cond then f prog else prog + + return $ + maybe + ghcProg + ( \v -> + -- By default, ignore GHC_ENVIRONMENT variable of any package environmnet + -- files. See #10759 + applyWhen (withinRange v canIgnorePackageEnv) ignorePackageEnv + -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825 + -- (spurious warning on non-english locales) + $ + applyWhen (withinRange v affectedVersionRange) setLanguageEnv $ + ghcProg + ) + (programVersion ghcProg) + runghcProgram :: Program -runghcProgram = (simpleProgram "runghc") { - programFindVersion = findProgramVersion "--version" $ \str -> - case words str of - -- "runghc 7.10.3" - (_:ver:_) -> ver - _ -> "" - } +runghcProgram = + (simpleProgram "runghc") + { programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "runghc 7.10.3" + (_ : ver : _) -> ver + _ -> "" + } ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } +ghcPkgProgram = + (simpleProgram "ghc-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } ghcjsProgram :: Program -ghcjsProgram = (simpleProgram "ghcjs") { - programFindVersion = findProgramVersion "--numeric-ghcjs-version" id - } +ghcjsProgram = + (simpleProgram "ghcjs") + { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id + } -- note: version is the version number of the GHC version that ghcjs-pkg was built with ghcjsPkgProgram :: Program -ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghcjs-pkg --version" gives a string like - -- "GHCJS package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -hmakeProgram :: Program -hmakeProgram = (simpleProgram "hmake") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } +ghcjsPkgProgram = + (simpleProgram "ghcjs-pkg") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghcjs-pkg --version" gives a string like + -- "GHCJS package manager version 6.4.1" + case words str of + (_ : _ : _ : _ : ver : _) -> ver + _ -> "" + } jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } +jhcProgram = + (simpleProgram "jhc") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_ : ver : _) -> ver + _ -> "" + } uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } +uhcProgram = + (simpleProgram "uhc") + { programFindVersion = findProgramVersion "--version-dotted" id + } hpcProgram :: Program -hpcProgram = (simpleProgram "hpc") - { - programFindVersion = findProgramVersion "version" $ \str -> - case words str of - (_ : _ : _ : ver : _) -> ver - _ -> "" +hpcProgram = + (simpleProgram "hpc") + { programFindVersion = findProgramVersion "version" $ \str -> + case words str of + (_ : _ : _ : ver : _) -> ver + _ -> "" } --- This represents a haskell-suite compiler. Of course, the compiler --- itself probably is not called "haskell-suite", so this is not a real --- program. (But we don't know statically the name of the actual compiler, --- so this is the best we can do.) --- --- Having this Program value serves two purposes: --- --- 1. We can accept options for the compiler in the form of --- --- --haskell-suite-option(s)=... --- --- 2. We can find a program later using this static id (with --- requireProgram). --- --- The path to the real compiler is found and recorded in the ProgramDb --- during the configure phase. -haskellSuiteProgram :: Program -haskellSuiteProgram = (simpleProgram "haskell-suite") { - -- pretend that the program exists, otherwise it won't be in the - -- "configured" state - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-dummy-location", []) - } - --- This represent a haskell-suite package manager. See the comments for --- haskellSuiteProgram. -haskellSuitePkgProgram :: Program -haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") { - programFindLocation = \_verbosity _searchPath -> - return $ Just ("haskell-suite-pkg-dummy-location", []) - } - - happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +happyProgram = + (simpleProgram "happy") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver - _ -> "" - } +alexProgram = + (simpleProgram "alex") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver + _ -> "" + } gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } +gccProgram = + (simpleProgram "gcc") + { programFindVersion = findProgramVersion "-dumpversion" id + } +gppProgram :: Program +gppProgram = + (simpleProgram "gpp") + { programFindVersion = findProgramVersion "-dumpversion" id + , programFindLocation = \v p -> findProgramOnSearchPath v p "g++" + } + arProgram :: Program arProgram = simpleProgram "ar" stripProgram :: Program -stripProgram = (simpleProgram "strip") { - programFindVersion = \verbosity -> - findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) - } +stripProgram = + (simpleProgram "strip") + { programFindVersion = \verbosity -> + findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity) + } hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +hsc2hsProgram = + (simpleProgram "hsc2hs") + { programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } +c2hsProgram = + (simpleProgram "c2hs") + { programFindVersion = findProgramVersion "--numeric-version" id + } cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } +cpphsProgram = + (simpleProgram "cpphs") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_ : ver : _) -> ver + _ -> "" + } hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } +hscolourProgram = + (simpleProgram "hscolour") + { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour" + , programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_ : ver : _) -> ver + _ -> "" + } -- TODO: Ensure that doctest is built against the same GHC as the one -- that's being used. Same for haddock. @phadej pointed this out. doctestProgram :: Program -doctestProgram = (simpleProgram "doctest") { - programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" - , programFindVersion = findProgramVersion "--version" $ \str -> - -- "doctest version 0.11.2" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } +doctestProgram = + (simpleProgram "doctest") + { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest" + , programFindVersion = findProgramVersion "--version" $ \str -> + -- "doctest version 0.11.2" + case words str of + (_ : _ : ver : _) -> ver + _ -> "" + } haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "", - - programNormaliseArgs = \_ _ args -> args - } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" +haddockProgram = + (simpleProgram "haddock") + { programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver + _ -> "" + , programNormaliseArgs = \_ _ args -> args + } ldProgram :: Program -ldProgram = simpleProgram "ld" +ldProgram = + (simpleProgram "ld") + { programPostConf = \verbosity ldProg -> do + -- The `lld` linker cannot create merge (relocatable) objects so we + -- want to detect this. + -- If the linker does support relocatable objects, we want to use that + -- to create partially pre-linked objects for GHCi, so we get much + -- faster loading as we do not have to do the separate loading and + -- in-memory linking the static linker in GHC does, but can offload + -- parts of this process to a pre-linking step. + -- However this requires the linker to support this features. Not all + -- linkers do, and notably as of this writing `lld` which is a popular + -- choice for windows linking does not support this feature. However + -- if using binutils ld or another linker that supports --relocatable, + -- we should still be good to generate pre-linked objects. + ldHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation ldProg ["--help"]) + -- In case the linker does not support '--help'. Eg the LLVM linker, + -- `lld` only accepts `-help`. + `catchIO` (\_ -> return "") + let k = "Supports relocatable output" + -- Standard GNU `ld` uses `--relocatable` while `ld.gold` uses + -- `-relocatable` (single `-`). + v + | "-relocatable" `isInfixOf` ldHelpOutput = "YES" + -- ld64 on macOS has this lovely response for "--help" + -- + -- ld64: For information on command line options please use 'man ld'. + -- + -- it does however support -r, if you read the manpage + -- (e.g. https://www.manpagez.com/man/1/ld64/) + | "ld64:" `isPrefixOf` ldHelpOutput = "YES" + | otherwise = "NO" + m = Map.insert k v (programProperties ldProg) + return $ ldProg{programProperties = m} + } + tarProgram :: Program -tarProgram = (simpleProgram "tar") { - -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the - -- '--format' option. - programPostConf = \verbosity tarProg -> do - tarHelpOutput <- getProgramInvocationOutput - verbosity (programInvocation tarProg ["--help"]) - -- Some versions of tar don't support '--help'. - `catchIO` (\_ -> return "") - let k = "Supports --format" - v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" - m = Map.insert k v (programProperties tarProg) - return $ tarProg { programProperties = m } - } +tarProgram = + (simpleProgram "tar") + { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the + -- '--format' option. + programPostConf = \verbosity tarProg -> do + tarHelpOutput <- + getProgramInvocationOutput + verbosity + (programInvocation tarProg ["--help"]) + -- Some versions of tar don't support '--help'. + `catchIO` (\_ -> return "") + let k = "Supports --format" + v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO" + m = Map.insert k v (programProperties tarProg) + return $ tarProg{programProperties = m} + } cppProgram :: Program cppProgram = simpleProgram "cpp" pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } +pkgConfigProgram = + (simpleProgram "pkg-config") + { programFindVersion = findProgramVersion "--version" id + , programPostConf = \_ pkgConfProg -> + let programOverrideEnv' = + programOverrideEnv pkgConfProg + ++ [ ("PKG_CONFIG_ALLOW_SYSTEM_CFLAGS", Just "1") + , ("PKG_CONFIG_ALLOW_SYSTEM_LIBS", Just "1") + ] + in pure $ pkgConfProg{programOverrideEnv = programOverrideEnv'} + } diff --git a/src/Distribution/Simple/Program/Db.hs b/src/Distribution/Simple/Program/Db.hs --- a/src/Distribution/Simple/Program/Db.hs +++ b/src/Distribution/Simple/Program/Db.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Db -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -23,62 +23,72 @@ -- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a -- hook user the ability to get the above flags and such so that they -- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, +module Distribution.Simple.Program.Db + ( -- * The collection of configured programs we can run + ProgramDb (..) + , emptyProgramDb + , defaultProgramDb + , restoreProgramDb -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - lookupKnownProgram, - knownPrograms, - getProgramSearchPath, - setProgramSearchPath, - modifyProgramSearchPath, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - updateProgram, - configuredPrograms, + , addKnownProgram + , addKnownPrograms + , prependProgramSearchPath + , prependProgramSearchPathNoLogging + , lookupKnownProgram + , knownPrograms + , getProgramSearchPath + , setProgramSearchPath + , modifyProgramSearchPath + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , lookupProgramByName + , updateProgram + , configuredPrograms -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - unconfigureProgram, - lookupProgramVersion, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - needProgram, + , configureProgram + , configureUnconfiguredProgram + , configureAllKnownPrograms + , unconfigureProgram + , lookupProgramVersion + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , needProgram + -- * Internal functions + , UnconfiguredProgs + , ConfiguredProgs + , updateUnconfiguredProgs + , updateConfiguredProgs ) where import Distribution.Compat.Prelude import Prelude () -import Distribution.Pretty import Distribution.Simple.Program.Builtin import Distribution.Simple.Program.Find import Distribution.Simple.Program.Types import Distribution.Simple.Utils -import Distribution.Utils.Structured (Structure (..), Structured (..)) +import Distribution.Utils.Structured (Structure (..), Structured (..)) import Distribution.Verbosity import Distribution.Version import Data.Tuple (swap) import qualified Data.Map as Map +import Distribution.Simple.Errors -- ------------------------------------------------------------ + -- * Programs database + -- ------------------------------------------------------------ -- | The configuration is a collection of information about programs. It @@ -89,75 +99,82 @@ -- by one we try to configure them at which point we move them into the -- configured collection. For unconfigured programs we record not just the -- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - progSearchPath :: ProgramSearchPath, - configuredProgs :: ConfiguredProgs - } - deriving (Typeable) +data ProgramDb = ProgramDb + { unconfiguredProgs :: UnconfiguredProgs + , progSearchPath :: ProgramSearchPath + , progOverrideEnv :: [(String, Maybe String)] + , configuredProgs :: ConfiguredProgs + } type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram emptyProgramDb :: ProgramDb -emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty +emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath [] Map.empty defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - -- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb +updateUnconfiguredProgs + :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb + -> ProgramDb updateUnconfiguredProgs update progdb = - progdb { unconfiguredProgs = update (unconfiguredProgs progdb) } + progdb{unconfiguredProgs = update (unconfiguredProgs progdb)} -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb +updateConfiguredProgs + :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb + -> ProgramDb updateConfiguredProgs update progdb = - progdb { configuredProgs = update (configuredProgs progdb) } - + progdb{configuredProgs = update (configuredProgs progdb)} -- Read & Show instances are based on listToFM -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Show ProgramDb where show = show . Map.toAscList . configuredProgs -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Read ProgramDb where readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] + [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r) + | (s', r) <- readsPrec p s + ] -- | Note that this instance does not preserve the known 'Program's. -- See 'restoreProgramDb' for details. --- instance Binary ProgramDb where put db = do put (progSearchPath db) + put (progOverrideEnv db) put (configuredProgs db) get = do searchpath <- get - progs <- get - return $! emptyProgramDb { - progSearchPath = searchpath, - configuredProgs = progs - } + overrides <- get + progs <- get + return $! + emptyProgramDb + { progSearchPath = searchpath + , progOverrideEnv = overrides + , configuredProgs = progs + } instance Structured ProgramDb where - structure p = Nominal (typeRep p) 0 "ProgramDb" - [ structure (Proxy :: Proxy ProgramSearchPath) - , structure (Proxy :: Proxy ConfiguredProgs) - ] - + structure p = + Nominal + (typeRep p) + 0 + "ProgramDb" + [ structure (Proxy :: Proxy ProgramSearchPath) + , structure (Proxy :: Proxy [(String, Maybe String)]) + , structure (Proxy :: Proxy ConfiguredProgs) + ] -- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the -- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because @@ -166,142 +183,177 @@ -- -- * It does not add the default programs, but you probably want them, use -- 'builtinPrograms' in addition to any extra you might need. --- restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb restoreProgramDb = addKnownPrograms - -- ------------------------------- -- Managing unconfigured programs -- | Add a known program that we may configure later --- addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - +addKnownProgram prog = + updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where + combine _ (_, path, args) = (prog, path, args) addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs - lookupKnownProgram :: String -> ProgramDb -> Maybe Program lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - + fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] knownPrograms progdb = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb) - , let p' = Map.lookup (programName p) (configuredProgs progdb) ] + [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb) + ] -- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This is the default list of locations where programs are looked for when -- configuring them. This can be overridden for specific programs (with -- 'userSpecifyPath'), and specific known programs can modify or ignore this -- search path in their own configuration code. --- getProgramSearchPath :: ProgramDb -> ProgramSearchPath getProgramSearchPath = progSearchPath -- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually set it before configuring any programs. --- setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb -setProgramSearchPath searchpath db = db { progSearchPath = searchpath } +setProgramSearchPath searchpath db = db{progSearchPath = searchpath} -- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'. -- This will affect programs that are configured from here on, so you -- should usually modify it before configuring any programs. --- -modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath) - -> ProgramDb - -> ProgramDb +modifyProgramSearchPath + :: (ProgramSearchPath -> ProgramSearchPath) + -> ProgramDb + -> ProgramDb modifyProgramSearchPath f db = setProgramSearchPath (f $ getProgramSearchPath db) db --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. +-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb' +-- by prepending the provided extra paths. -- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb -userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) +-- - Logs the added paths in info verbosity. +-- - Prepends environment variable overrides. +prependProgramSearchPath + :: Verbosity + -> [FilePath] + -> [(String, Maybe FilePath)] + -> ProgramDb + -> IO ProgramDb +prependProgramSearchPath verbosity extraPaths extraEnv db = do + unless (null extraPaths) $ + logExtraProgramSearchPath verbosity extraPaths + unless (null extraEnv) $ + logExtraProgramOverrideEnv verbosity extraEnv + return $ prependProgramSearchPathNoLogging extraPaths extraEnv db +prependProgramSearchPathNoLogging + :: [FilePath] + -> [(String, Maybe String)] + -> ProgramDb + -> ProgramDb +prependProgramSearchPathNoLogging extraPaths extraEnv db = + let db' = modifyProgramSearchPath (nub . (map ProgramSearchPathDir extraPaths ++)) db + db'' = db'{progOverrideEnv = extraEnv ++ progOverrideEnv db'} + in db'' -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing progdb = progdb -userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb +-- | User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +userSpecifyPath + :: String + -- ^ Program name + -> FilePath + -- ^ user-specified path to the program + -> ProgramDb + -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ + \(prog, _, args) -> Just (prog, Just path, args) +userMaybeSpecifyPath + :: String + -> Maybe FilePath + -> ProgramDb + -> ProgramDb +userMaybeSpecifyPath _ Nothing progdb = progdb +userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb +-- | User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs + :: String + -- ^ Program name + -> [ProgArg] + -- ^ user-specified args + -> ProgramDb + -> ProgramDb userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - + updateUnconfiguredProgs + ( flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args') + ) + . updateConfiguredProgs + ( flip Map.update name $ + \prog -> + Just + prog + { programOverrideArgs = + programOverrideArgs prog + ++ args' + } + ) -- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb +userSpecifyPaths + :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb userSpecifyPaths paths progdb = foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths - -- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb +userSpecifyArgss + :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb userSpecifyArgss argss progdb = foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss - -- | Get the path that has been previously specified for a program, if any. --- userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - + join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs -- | Get any extra args that have been previously specified for a program. --- userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - + maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs -- ----------------------------- -- Managing configured programs -- | Try to find a configured program lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs +lookupProgram = lookupProgramByName . programName +-- | Try to find a configured program +lookupProgramByName :: String -> ProgramDb -> Maybe ConfiguredProgram +lookupProgramByName name = Map.lookup name . configuredProgs -- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - +updateProgram + :: ConfiguredProgram + -> ProgramDb + -> ProgramDb +updateProgram prog = + updateConfiguredProgs $ + Map.insert (programId prog) prog -- | List all configured programs. configuredPrograms :: ProgramDb -> [ConfiguredProgram] @@ -310,11 +362,13 @@ -- --------------------------- -- Configuring known programs --- | Try to configure a specific program. If the program is already included in --- the collection of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured successfully it gets --- added to the configured collection. +-- | Try to configure a specific program and add it to the program database. -- +-- If the program is already included in the collection of unconfigured programs, +-- then we use any user-supplied location and arguments. +-- If the program gets configured successfully, it gets added to the configured +-- collection. +-- -- Note that it is not a failure if the program cannot be configured. It's only -- a failure if the user supplied a location and the program could not be found -- at that location. @@ -323,57 +377,73 @@ -- front all the programs we will need, so we try to configure them all. -- To verify that a program was actually successfully configured use -- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb +configureProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb configureProgram verbosity prog progdb = do + mbConfiguredProg <- configureUnconfiguredProgram verbosity prog progdb + case mbConfiguredProg of + Nothing -> return progdb + Just configuredProg -> do + let progdb' = + updateConfiguredProgs + (Map.insert (programName prog) configuredProg) + progdb + return progdb' + +-- | Try to configure a specific program. If the program is already included in +-- the collection of unconfigured programs then we use any user-supplied +-- location and arguments. +configureUnconfiguredProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe ConfiguredProgram) +configureUnconfiguredProgram verbosity prog progdb = do let name = programName prog maybeLocation <- case userSpecifiedPath prog progdb of - Nothing -> + Nothing -> programFindLocation prog verbosity (progSearchPath progdb) - >>= return . fmap (swap . fmap FoundOnSystem . swap) + >>= return . fmap (swap . fmap FoundOnSystem . swap) Just path -> do absolute <- doesExecutableExist path if absolute then return (Just (UserSpecified path, [])) - else findProgramOnSearchPath verbosity (progSearchPath progdb) path - >>= maybe (die' verbosity notFound) - (return . Just . swap . fmap UserSpecified . swap) - where notFound = "Cannot find the program '" ++ name - ++ "'. User-specified path '" - ++ path ++ "' does not refer to an executable and " - ++ "the program is not on the system path." + else + findProgramOnSearchPath verbosity (progSearchPath progdb) path + >>= maybe + (dieWithException verbosity $ ConfigureProgram name path) + (return . Just . swap . fmap UserSpecified . swap) case maybeLocation of - Nothing -> return progdb + Nothing -> return Nothing Just (location, triedLocations) -> do version <- programFindVersion prog verbosity (locationPath location) newPath <- programSearchPathAsPATHVar (progSearchPath progdb) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog progdb, - programOverrideEnv = [("PATH", Just newPath)], - programProperties = Map.empty, - programLocation = location, - programMonitorFiles = triedLocations - } + let configuredProg = + ConfiguredProgram + { programId = name + , programVersion = version + , programDefaultArgs = [] + , programOverrideArgs = userSpecifiedArgs prog progdb + , programOverrideEnv = [("PATH", Just newPath)] ++ progOverrideEnv progdb + , programProperties = Map.empty + , programLocation = location + , programMonitorFiles = triedLocations + } configuredProg' <- programPostConf prog verbosity configuredProg - return (updateConfiguredProgs (Map.insert name configuredProg') progdb) - + return $ Just configuredProg' -- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb +configurePrograms + :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb configurePrograms verbosity progs progdb = foldM (flip (configureProgram verbosity)) progdb progs - -- | Unconfigure a program. This is basically a hack and you shouldn't -- use it, but it can be handy for making sure a 'requireProgram' -- actually reconfigures. @@ -382,51 +452,51 @@ updateConfiguredProgs $ Map.delete progname -- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb +configureAllKnownPrograms + :: Verbosity + -> ProgramDb + -> IO ProgramDb configureAllKnownPrograms verbosity progdb = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb + configurePrograms + verbosity + [prog | (prog, _, _) <- Map.elems notYetConfigured] + progdb where - notYetConfigured = unconfiguredProgs progdb - `Map.difference` configuredProgs progdb - + notYetConfigured = + unconfiguredProgs progdb + `Map.difference` configuredProgs progdb -- | reconfigure a bunch of programs given new user-specified args. It takes -- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs -- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb +reconfigurePrograms + :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb reconfigurePrograms verbosity paths argss progdb = do configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ progdb - + . userSpecifyPaths paths + . userSpecifyArgss argss + $ progdb where - progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ] - + progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths] -- | Check that a program is configured and available to be run. -- -- It raises an exception if the program could not be configured, otherwise -- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) +requireProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) requireProgram verbosity prog progdb = do - mres <- needProgram verbosity prog progdb - case mres of - Nothing -> die' verbosity notFound - Just res -> return res - where - notFound = "The program '" ++ programName prog ++ "' is required but it could not be found." + mres <- needProgram verbosity prog progdb + case mres of + Nothing -> dieWithException verbosity $ RequireProgram (programName prog) + Just res -> return res -- | Check that a program is configured and available to be run. -- @@ -434,17 +504,19 @@ -- or is not found. -- -- @since 3.0.1.0 -needProgram :: Verbosity -> Program -> ProgramDb - -> IO (Maybe (ConfiguredProgram, ProgramDb)) +needProgram + :: Verbosity + -> Program + -> ProgramDb + -> IO (Maybe (ConfiguredProgram, ProgramDb)) needProgram verbosity prog progdb = do - -- If it's not already been configured, try to configure it now progdb' <- case lookupProgram prog progdb of Nothing -> configureProgram verbosity prog progdb - Just _ -> return progdb + Just _ -> return progdb case lookupProgram prog progdb' of - Nothing -> return Nothing + Nothing -> return Nothing Just configuredProg -> return (Just (configuredProg, progdb')) -- | Check that a program is configured and available to be run. @@ -456,50 +528,39 @@ -- It returns the configured program, its version number and a possibly updated -- 'ProgramDb'. If the program could not be configured or the version is -- unsuitable, it returns an error value. --- lookupProgramVersion - :: Verbosity -> Program -> VersionRange -> ProgramDb - -> IO (Either String (ConfiguredProgram, Version, ProgramDb)) + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (Either CabalException (ConfiguredProgram, Version, ProgramDb)) lookupProgramVersion verbosity prog range programDb = do - -- If it's not already been configured, try to configure it now programDb' <- case lookupProgram prog programDb of Nothing -> configureProgram verbosity prog programDb - Just _ -> return programDb + Just _ -> return programDb case lookupProgram prog programDb' of - Nothing -> return $! Left notFound - Just configuredProg@ConfiguredProgram { programLocation = location } -> + Nothing -> return $! Left $ NoProgramFound (programName prog) range + Just configuredProg@ConfiguredProgram{programLocation = location} -> case programVersion configuredProg of Just version | withinRange version range -> - return $! Right (configuredProg, version ,programDb') - | otherwise -> - return $! Left (badVersion version location) - Nothing -> - return $! Left (unknownVersion location) - - where notFound = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ prettyShow v - unknownVersion l = "The program '" - ++ programName prog ++ "'" ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ prettyShow range + return $! Right (configuredProg, version, programDb') + | otherwise -> + return $! Left $ BadVersionDb (programName prog) version range (locationPath location) + Nothing -> + return $! Left $ UnknownVersionDb (programName prog) range (locationPath location) -- | Like 'lookupProgramVersion', but raises an exception in case of error -- instead of returning 'Left errMsg'. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion + :: Verbosity + -> Program + -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) requireProgramVersion verbosity prog range programDb = - join $ either (die' verbosity) return `fmap` - lookupProgramVersion verbosity prog range programDb + join $ + either (dieWithException verbosity) return + `fmap` lookupProgramVersion verbosity prog range programDb diff --git a/src/Distribution/Simple/Program/Find.hs b/src/Distribution/Simple/Program/Find.hs --- a/src/Distribution/Simple/Program/Find.hs +++ b/src/Distribution/Simple/Program/Find.hs @@ -1,10 +1,9 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Find -- Copyright : Duncan Coutts 2013 @@ -24,139 +23,173 @@ -- So we need an extension of the usual 'findExecutable' that can look in -- additional locations, either before, after or instead of the normal OS -- locations. --- -module Distribution.Simple.Program.Find ( - -- * Program search path - ProgramSearchPath, - ProgramSearchPathEntry(..), - defaultProgramSearchPath, - findProgramOnSearchPath, - programSearchPathAsPATHVar, - getSystemSearchPath, +module Distribution.Simple.Program.Find + ( -- * Program search path + ProgramSearchPath + , ProgramSearchPathEntry (..) + , defaultProgramSearchPath + , findProgramOnSearchPath + , programSearchPathAsPATHVar + , logExtraProgramSearchPath + , logExtraProgramOverrideEnv + , getSystemSearchPath + , getExtraPathEnv + , simpleProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Verbosity +import Distribution.Compat.Environment +import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.System -import Distribution.Compat.Environment +import Distribution.Verbosity import qualified System.Directory as Directory - ( findExecutable ) + ( findExecutable + ) import System.FilePath as FilePath - ( (), (<.>), splitSearchPath, searchPathSeparator, getSearchPath - , takeDirectory ) + ( getSearchPath + , searchPathSeparator + , splitSearchPath + , takeDirectory + , (<.>) + , () + ) #if defined(mingw32_HOST_OS) import qualified System.Win32 as Win32 #endif --- | A search path to use when locating executables. This is analogous --- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use --- the system default method for finding executables ('findExecutable' which --- on unix is simply looking on the @$PATH@ but on win32 is a bit more --- complicated). --- --- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs --- either before, after or instead of the default, e.g. here we add an extra --- dir to search after the usual ones. --- --- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] --- -type ProgramSearchPath = [ProgramSearchPathEntry] -data ProgramSearchPathEntry = - ProgramSearchPathDir FilePath -- ^ A specific dir - | ProgramSearchPathDefault -- ^ The system default - deriving (Eq, Generic, Typeable) - -instance Binary ProgramSearchPathEntry -instance Structured ProgramSearchPathEntry - defaultProgramSearchPath :: ProgramSearchPath defaultProgramSearchPath = [ProgramSearchPathDefault] -findProgramOnSearchPath :: Verbosity -> ProgramSearchPath - -> FilePath -> IO (Maybe (FilePath, [FilePath])) +logExtraProgramSearchPath + :: Verbosity + -> [FilePath] + -> IO () +logExtraProgramSearchPath verbosity extraPaths = + info verbosity . unlines $ + "Including the following directories in PATH:" + : map ("- " ++) extraPaths + +logExtraProgramOverrideEnv + :: Verbosity + -> [(String, Maybe String)] + -> IO () +logExtraProgramOverrideEnv verbosity extraEnv = + info verbosity . unlines $ + "Including the following environment variable overrides:" + : [ "- " ++ case mbVal of + Nothing -> "unset " ++ var + Just val -> var ++ "=" ++ val + | (var, mbVal) <- extraEnv + ] + +findProgramOnSearchPath + :: Verbosity + -> ProgramSearchPath + -> FilePath + -> IO (Maybe (FilePath, [FilePath])) findProgramOnSearchPath verbosity searchpath prog = do - debug verbosity $ "Searching for " ++ prog ++ " in path." - res <- tryPathElems [] searchpath - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path) - return res + debug verbosity $ "Searching for " ++ prog ++ " in path." + res <- tryPathElems [] searchpath + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path) + return res where - tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry] - -> IO (Maybe (FilePath, [FilePath])) - tryPathElems _ [] = return Nothing - tryPathElems tried (pe:pes) = do + tryPathElems + :: [[FilePath]] + -> [ProgramSearchPathEntry] + -> IO (Maybe (FilePath, [FilePath])) + tryPathElems _ [] = return Nothing + tryPathElems tried (pe : pes) = do res <- tryPathElem pe case res of - (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes + (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes (Just foundat, notfoundat) -> return (Just (foundat, alltried)) where alltried = concat (reverse (notfoundat : tried)) tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath]) tryPathElem (ProgramSearchPathDir dir) = - findFirstExe [ dir prog <.> ext | ext <- exeExtensions ] - + findFirstExe [dir prog <.> ext | ext <- exeExtensions] -- On windows, getSystemSearchPath is not guaranteed 100% correct so we -- use findExecutable and then approximate the not-found-at locations. tryPathElem ProgramSearchPathDefault | buildOS == Windows = do - mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ] + mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions] syspath <- getSystemSearchPath case mExe of Nothing -> - let notfoundat = [ dir prog | dir <- syspath ] in - return (Nothing, notfoundat) - + let notfoundat = [dir prog | dir <- syspath] + in return (Nothing, notfoundat) Just foundat -> do - let founddir = takeDirectory foundat - notfoundat = [ dir prog - | dir <- takeWhile (/= founddir) syspath ] + let founddir = takeDirectory foundat + notfoundat = + [ dir prog + | dir <- takeWhile (/= founddir) syspath + ] return (Just foundat, notfoundat) -- On other OSs we can just do the simple thing tryPathElem ProgramSearchPathDefault = do dirs <- getSystemSearchPath - findFirstExe [ dir prog <.> ext | dir <- dirs, ext <- exeExtensions ] + findFirstExe [dir prog <.> ext | dir <- dirs, ext <- exeExtensions] findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath]) findFirstExe = go [] where - go fs' [] = return (Nothing, reverse fs') - go fs' (f:fs) = do + go fs' [] = return (Nothing, reverse fs') + go fs' (f : fs) = do isExe <- doesExecutableExist f if isExe then return (Just f, reverse fs') - else go (f:fs') fs + else go (f : fs') fs -- Helper for evaluating actions until the first one returns 'Just' firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a) firstJustM [] = return Nothing - firstJustM (ma:mas) = do + firstJustM (ma : mas) = do a <- ma case a of - Just _ -> return a + Just _ -> return a Nothing -> firstJustM mas +-- | Adds some paths to the "PATH" entry in the key-value environment provided +-- or if there is none, looks up @$PATH@ in the real environment. +getExtraPathEnv + :: Verbosity + -> [(String, Maybe String)] + -> [FilePath] + -> IO [(String, Maybe String)] +getExtraPathEnv _ _ [] = return [] +getExtraPathEnv verbosity env extras = do + mb_path <- case lookup "PATH" env of + Just x -> return x + Nothing -> lookupEnv "PATH" + logExtraProgramSearchPath verbosity extras + let extra = intercalate [searchPathSeparator] extras + path' = case mb_path of + Nothing -> extra + Just path -> extra ++ searchPathSeparator : path + return [("PATH", Just path')] + -- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var. -- Note that this is close but not perfect because on Windows the search -- algorithm looks at more than just the @%PATH%@. programSearchPathAsPATHVar :: ProgramSearchPath -> IO String programSearchPathAsPATHVar searchpath = do - ess <- traverse getEntries searchpath - return (intercalate [searchPathSeparator] (concat ess)) + ess <- traverse getEntries searchpath + return (intercalate [searchPathSeparator] (concat ess)) where getEntries (ProgramSearchPathDir dir) = return [dir] - getEntries ProgramSearchPathDefault = do + getEntries ProgramSearchPathDefault = do env <- getEnvironment return (maybe [] splitSearchPath (lookup "PATH" env)) -- | Get the system search path. On Unix systems this is just the @$PATH@ env -- var, but on windows it's a bit more complicated. --- getSystemSearchPath :: IO [FilePath] getSystemSearchPath = fmap nub $ do #if defined(mingw32_HOST_OS) @@ -196,3 +229,18 @@ _ -> return mExe #endif +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } +simpleProgram :: String -> Program +simpleProgram name = + Program + { programName = name + , programFindLocation = \v p -> findProgramOnSearchPath v p name + , programFindVersion = \_ _ -> return Nothing + , programPostConf = \_ p -> return p + , programNormaliseArgs = \_ _ -> id + } diff --git a/src/Distribution/Simple/Program/GHC.hs b/src/Distribution/Simple/Program/GHC.hs --- a/src/Distribution/Simple/Program/GHC.hs +++ b/src/Distribution/Simple/Program/GHC.hs @@ -1,843 +1,1078 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Simple.Program.GHC ( - GhcOptions(..), - GhcMode(..), - GhcOptimisation(..), - GhcDynLinkMode(..), - GhcProfAuto(..), - - ghcInvocation, - renderGhcOptions, - - runGHC, - - packageDbArgsDb, - normaliseGhcArgs - - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Backpack -import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..)) -import Distribution.Simple.GHC.ImplInfo -import Distribution.PackageDescription -import Distribution.ModuleName -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.System -import Distribution.Pretty -import Distribution.Types.ComponentId -import Distribution.Verbosity -import Distribution.Version -import Distribution.Utils.NubList -import Language.Haskell.Extension - -import Data.List (stripPrefix) -import qualified Data.Map as Map -import Data.Monoid (All(..), Any(..), Endo(..)) -import qualified Data.Set as Set - -normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] -normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs - | ghcVersion `withinRange` supportedGHCVersions - = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs - where - supportedGHCVersions :: VersionRange - supportedGHCVersions = intersectVersionRanges - (orLaterVersion (mkVersion [8,0])) - (earlierVersion (mkVersion [9,1])) - - from :: Monoid m => [Int] -> m -> m - from version flags - | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags - | otherwise = mempty - - to :: Monoid m => [Int] -> m -> m - to version flags - | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags - | otherwise = mempty - - checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m - checkGhcFlags fun = mconcat - [ fun ghcArgs - , checkComponentFlags libBuildInfo pkgLibs - , checkComponentFlags buildInfo executables - , checkComponentFlags testBuildInfo testSuites - , checkComponentFlags benchmarkBuildInfo benchmarks - ] - where - pkgLibs = maybeToList library ++ subLibraries - - checkComponentFlags :: (a -> BuildInfo) -> [a] -> m - checkComponentFlags getInfo = foldMap (checkComponent . getInfo) - where - checkComponent :: BuildInfo -> m - checkComponent = foldMap fun . filterGhcOptions . allGhcOptions - - allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] - allGhcOptions = foldMap (perCompilerFlavorToList .) - [options, profOptions, sharedOptions, staticOptions] - - filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] - filterGhcOptions l = [opts | (GHC, opts) <- l] - - safeToFilterWarnings :: Bool - safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings - where - checkWarnings :: [String] -> All - checkWarnings = All . Set.null . foldr alter Set.empty - - alter :: String -> Set String -> Set String - alter flag = appEndo $ mconcat - [ \s -> Endo $ if s == "-Werror" then Set.insert s else id - , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id - , \s -> from [8,6] . Endo $ - if s == "-Werror=compat" - then Set.union compatWarningSet else id - , \s -> from [8,6] . Endo $ - if s == "-Wno-error=compat" - then (`Set.difference` compatWarningSet) else id - , \s -> from [8,6] . Endo $ - if s == "-Wwarn=compat" - then (`Set.difference` compatWarningSet) else id - , from [8,4] $ markFlag "-Werror=" Set.insert - , from [8,4] $ markFlag "-Wwarn=" Set.delete - , from [8,4] $ markFlag "-Wno-error=" Set.delete - ] flag - - markFlag - :: String - -> (String -> Set String -> Set String) - -> String - -> Endo (Set String) - markFlag name update flag = Endo $ case stripPrefix name flag of - Just rest | not (null rest) && rest /= "compat" -> update rest - _ -> id - - flagArgumentFilter :: [String] -> [String] -> [String] - flagArgumentFilter flags = go - where - makeFilter :: String -> String -> Option' (First' ([String] -> [String])) - makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg - where - filterRest leftOver = case dropEq leftOver of - [] -> drop 1 - _ -> id - - checkFilter :: String -> Maybe ([String] -> [String]) - checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags - - go :: [String] -> [String] - go [] = [] - go (arg:args) = case checkFilter arg of - Just f -> go (f args) - Nothing -> arg : go args - - argumentFilters :: [String] -> [String] - argumentFilters = flagArgumentFilter - ["-ghci-script", "-H", "-interactive-print"] - - filterRtsOpts :: [String] -> [String] - filterRtsOpts = go False - where - go :: Bool -> [String] -> [String] - go _ [] = [] - go _ ("+RTS":opts) = go True opts - go _ ("-RTS":opts) = go False opts - go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts - where - addOpt | isRTSopts = id - | otherwise = (opt:) - - simpleFilters :: String -> Bool - simpleFilters = not . getAny . mconcat - [ flagIn simpleFlags - , Any . isPrefixOf "-ddump-" - , Any . isPrefixOf "-dsuppress-" - , Any . isPrefixOf "-dno-suppress-" - , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] - , flagIn . invertibleFlagSet "-f" . mconcat $ - [ [ "reverse-errors", "warn-unused-binds", "break-on-error" - , "break-on-exception", "print-bind-result" - , "print-bind-contents", "print-evld-with-show" - , "implicit-import-qualified", "error-spans" - ] - , from [7,8] - [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options - , "print-explicit-kinds" - ] - , from [8,0] - [ "print-explicit-coercions" - , "print-explicit-runtime-reps" - , "print-equality-relations" - , "print-unicode-syntax" - , "print-expanded-synonyms" - , "print-potential-instances" - , "print-typechecker-elaboration" - ] - , from [8,2] - [ "diagnostics-show-caret", "local-ghci-history" - , "show-warning-groups", "hide-source-paths" - , "show-hole-constraints" - ] - , from [8,4] ["show-loaded-modules"] - , from [8,6] [ "ghci-leak-check", "no-it" ] - , from [8,10] - [ "defer-diagnostics" -- affects printing of diagnostics - , "keep-going" -- try harder, the build will still fail if it's erroneous - , "print-axiom-incomps" -- print more debug info for closed type families - ] - ] - , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ] - , isOptIntFlag - , isIntFlag - , if safeToFilterWarnings - then isWarning <> (Any . ("-w"==)) - else mempty - , from [8,6] $ - if safeToFilterHoles - then isTypedHoleFlag - else mempty - ] - - flagIn :: Set String -> String -> Any - flagIn set flag = Any $ Set.member flag set - - isWarning :: String -> Any - isWarning = mconcat $ map ((Any .) . isPrefixOf) - ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] - - simpleFlags :: Set String - simpleFlags = Set.fromList . mconcat $ - [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats" - , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core" - , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint" - , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats" - , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp" - , "-fno-force-recomp" - ] - - , from [8,2] - [ "-fno-max-errors", "-fdiagnostics-color=auto" - , "-fdiagnostics-color=always", "-fdiagnostics-color=never" - , "-dppr-debug", "-dno-debug-output" - ] - - , from [8,4] [ "-ddebug-output" ] - , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ] - , from [8,6] [ "-dhex-word-literals" ] - , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ] - , from [9,0] [ "-dlinear-core-lint" ] - ] - - isOptIntFlag :: String -> Any - isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] - - isIntFlag :: String -> Any - isIntFlag = mconcat . map (dropIntFlag False) . mconcat $ - [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols" - , "-dtrace-level", "-fghci-hist-size" ] - , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"] - , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"] - ] - - dropIntFlag :: Bool -> String -> String -> Any - dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of - Nothing -> False - Just rest | isOpt && null rest -> True - | otherwise -> case parseInt rest of - Just _ -> True - Nothing -> False - where - parseInt :: String -> Maybe Int - parseInt = readMaybe . dropEq - - dropEq :: String -> String - dropEq ('=':s) = s - dropEq s = s - - invertibleFlagSet :: String -> [String] -> Set String - invertibleFlagSet prefix flagNames = - Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames - - compatWarningSet :: Set String - compatWarningSet = Set.fromList $ mconcat - [ from [8,6] - [ "missing-monadfail-instances", "semigroup" - , "noncanonical-monoid-instances", "implicit-kind-vars" ] - ] - - safeToFilterHoles :: Bool - safeToFilterHoles = getAll . checkGhcFlags $ - All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred - where - notDeferred :: String -> Option' (Last' Bool) - notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False - notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True - notDeferred _ = Option' Nothing - - isTypedHoleFlag :: String -> Any - isTypedHoleFlag = mconcat - [ flagIn . invertibleFlagSet "-f" $ - [ "show-hole-constraints", "show-valid-substitutions" - , "show-valid-hole-fits", "sort-valid-hole-fits" - , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits" - , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits" - , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits" - , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits" - , "unclutter-valid-hole-fits" - ] - , flagIn . Set.fromList $ - [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits" - , "-fno-refinement-level-hole-fits" ] - , mconcat . map (dropIntFlag False) $ - [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits" - , "-frefinement-level-hole-fits" ] - ] - -normaliseGhcArgs _ _ args = args - --- | A structured set of GHC options/flags --- --- Note that options containing lists fall into two categories: --- --- * options that can be safely deduplicated, e.g. input modules or --- enabled extensions; --- * options that cannot be deduplicated in general without changing --- semantics, e.g. extra ghc options or linking options. -data GhcOptions = GhcOptions { - - -- | The major mode for the ghc invocation. - ghcOptMode :: Flag GhcMode, - - -- | Any extra options to pass directly to ghc. These go at the end and hence - -- override other stuff. - ghcOptExtra :: [String], - - -- | Extra default flags to pass directly to ghc. These go at the beginning - -- and so can be overridden by other stuff. - ghcOptExtraDefault :: [String], - - ----------------------- - -- Inputs and outputs - - -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. - ghcOptInputFiles :: NubListR FilePath, - - -- | The names of input Haskell modules, mainly for @--make@ mode. - ghcOptInputModules :: NubListR ModuleName, - - -- | Location for output file; the @ghc -o@ flag. - ghcOptOutputFile :: Flag FilePath, - - -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; - -- the @ghc -dyno@ flag. - ghcOptOutputDynFile :: Flag FilePath, - - -- | Start with an empty search path for Haskell source files; - -- the @ghc -i@ flag (@-i@ on its own with no path argument). - ghcOptSourcePathClear :: Flag Bool, - - -- | Search path for Haskell source files; the @ghc -i@ flag. - ghcOptSourcePath :: NubListR FilePath, - - ------------- - -- Packages - - -- | The unit ID the modules will belong to; the @ghc -this-unit-id@ - -- flag (or @-this-package-key@ or @-package-name@ on older - -- versions of GHC). This is a 'String' because we assume you've - -- already figured out what the correct format for this string is - -- (we need to handle backwards compatibility.) - ghcOptThisUnitId :: Flag String, - - -- | GHC doesn't make any assumptions about the format of - -- definite unit ids, so when we are instantiating a package it - -- needs to be told explicitly what the component being instantiated - -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty - ghcOptThisComponentId :: Flag ComponentId, - - -- | How the requirements of the package being compiled are to - -- be filled. When typechecking an indefinite package, the 'OpenModule' - -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module - -- that instantiates a package. - ghcOptInstantiatedWith :: [(ModuleName, OpenModule)], - - -- | No code? (But we turn on interface writing - ghcOptNoCode :: Flag Bool, - - -- | GHC package databases to use, the @ghc -package-conf@ flag. - ghcOptPackageDBs :: PackageDBStack, - - -- | The GHC packages to bring into scope when compiling, - -- the @ghc -package-id@ flags. - ghcOptPackages :: - NubListR (OpenUnitId, ModuleRenaming), - - -- | Start with a clean package set; the @ghc -hide-all-packages@ flag - ghcOptHideAllPackages :: Flag Bool, - - -- | Warn about modules, not listed in command line - ghcOptWarnMissingHomeModules :: Flag Bool, - - -- | Don't automatically link in Haskell98 etc; the @ghc - -- -no-auto-link-packages@ flag. - ghcOptNoAutoLinkPackages :: Flag Bool, - - ----------------- - -- Linker stuff - - -- | Names of libraries to link in; the @ghc -l@ flag. - ghcOptLinkLibs :: [FilePath], - - -- | Search path for libraries to link in; the @ghc -L@ flag. - ghcOptLinkLibPath :: NubListR FilePath, - - -- | Options to pass through to the linker; the @ghc -optl@ flag. - ghcOptLinkOptions :: [String], - - -- | OSX only: frameworks to link in; the @ghc -framework@ flag. - ghcOptLinkFrameworks :: NubListR String, - - -- | OSX only: Search path for frameworks to link in; the - -- @ghc -framework-path@ flag. - ghcOptLinkFrameworkDirs :: NubListR String, - - -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. - ghcOptNoLink :: Flag Bool, - - -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ - -- flag. - ghcOptLinkNoHsMain :: Flag Bool, - - -- | Module definition files (Windows specific) - ghcOptLinkModDefFiles :: NubListR FilePath, - - -------------------- - -- C and CPP stuff - - -- | Options to pass through to the C compiler; the @ghc -optc@ flag. - ghcOptCcOptions :: [String], - - -- | Options to pass through to the C++ compiler. - ghcOptCxxOptions :: [String], - - -- | Options to pass through to the Assembler. - ghcOptAsmOptions :: [String], - - -- | Options to pass through to CPP; the @ghc -optP@ flag. - ghcOptCppOptions :: [String], - - -- | Search path for CPP includes like header files; the @ghc -I@ flag. - ghcOptCppIncludePath :: NubListR FilePath, - - -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. - ghcOptCppIncludes :: NubListR FilePath, - - -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. - ghcOptFfiIncludes :: NubListR FilePath, - - ---------------------------- - -- Language and extensions - - -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. - ghcOptLanguage :: Flag Language, - - -- | The language extensions; the @ghc -X@ flag. - ghcOptExtensions :: NubListR Extension, - - -- | A GHC version-dependent mapping of extensions to flags. This must be - -- set to be able to make use of the 'ghcOptExtensions'. - ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag), - - ---------------- - -- Compilation - - -- | What optimisation level to use; the @ghc -O@ flag. - ghcOptOptimisation :: Flag GhcOptimisation, - - -- | Emit debug info; the @ghc -g@ flag. - ghcOptDebugInfo :: Flag DebugInfoLevel, - - -- | Compile in profiling mode; the @ghc -prof@ flag. - ghcOptProfilingMode :: Flag Bool, - - -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. - ghcOptProfilingAuto :: Flag GhcProfAuto, - - -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag. - ghcOptSplitSections :: Flag Bool, - - -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. - ghcOptSplitObjs :: Flag Bool, - - -- | Run N jobs simultaneously (if possible). - ghcOptNumJobs :: Flag (Maybe Int), - - -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. - ghcOptHPCDir :: Flag FilePath, - - ---------------- - -- GHCi - - -- | Extra GHCi startup scripts; the @-ghci-script@ flag - ghcOptGHCiScripts :: [FilePath], - - ------------------------ - -- Redirecting outputs - - ghcOptHiSuffix :: Flag String, - ghcOptObjSuffix :: Flag String, - ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode - ghcOptHiDir :: Flag FilePath, - ghcOptObjDir :: Flag FilePath, - ghcOptOutputDir :: Flag FilePath, - ghcOptStubDir :: Flag FilePath, - - -------------------- - -- Creating libraries - - ghcOptDynLinkMode :: Flag GhcDynLinkMode, - ghcOptStaticLib :: Flag Bool, - ghcOptShared :: Flag Bool, - ghcOptFPic :: Flag Bool, - ghcOptDylibName :: Flag String, - ghcOptRPaths :: NubListR FilePath, - - --------------- - -- Misc flags - - -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. - ghcOptVerbosity :: Flag Verbosity, - - -- | Put the extra folders in the PATH environment variable we invoke - -- GHC with - ghcOptExtraPath :: NubListR FilePath, - - -- | Let GHC know that it is Cabal that's calling it. - -- Modifies some of the GHC error messages. - ghcOptCabal :: Flag Bool - -} deriving (Show, Generic) - - -data GhcMode = GhcModeCompile -- ^ @ghc -c@ - | GhcModeLink -- ^ @ghc@ - | GhcModeMake -- ^ @ghc --make@ - | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ - | GhcModeAbiHash -- ^ @ghc --abi-hash@ --- | GhcModeDepAnalysis -- ^ @ghc -M@ --- | GhcModeEvaluate -- ^ @ghc -e@ - deriving (Show, Eq) - -data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ - | GhcNormalOptimisation -- ^ @-O@ - | GhcMaximumOptimisation -- ^ @-O2@ - | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ - deriving (Show, Eq) - -data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ - | GhcDynamicOnly -- ^ @-dynamic@ - | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ - deriving (Show, Eq) - -data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@ - | GhcProfAutoToplevel -- ^ @-fprof-auto-top@ - | GhcProfAutoExported -- ^ @-fprof-auto-exported@ - deriving (Show, Eq) - -runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> IO () -runGHC verbosity ghcProg comp platform opts = do - runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts) - - -ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions - -> ProgramInvocation -ghcInvocation prog comp platform opts = - (programInvocation prog (renderGhcOptions comp platform opts)) { - progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) - } - -renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] -renderGhcOptions comp _platform@(Platform _arch os) opts - | compilerFlavor comp `notElem` [GHC, GHCJS] = - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ "compiler flavor must be 'GHC' or 'GHCJS'!" - | otherwise = - concat - [ case flagToMaybe (ghcOptMode opts) of - Nothing -> [] - Just GhcModeCompile -> ["-c"] - Just GhcModeLink -> [] - Just GhcModeMake -> ["--make"] - Just GhcModeInteractive -> ["--interactive"] - Just GhcModeAbiHash -> ["--abi-hash"] --- Just GhcModeDepAnalysis -> ["-M"] --- Just GhcModeEvaluate -> ["-e", expr] - - , ghcOptExtraDefault opts - - , [ "-no-link" | flagBool ghcOptNoLink ] - - --------------- - -- Misc flags - - , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) - - , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ] - - ---------------- - -- Compilation - - , case flagToMaybe (ghcOptOptimisation opts) of - Nothing -> [] - Just GhcNoOptimisation -> ["-O0"] - Just GhcNormalOptimisation -> ["-O"] - Just GhcMaximumOptimisation -> ["-O2"] - Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph - - , case flagToMaybe (ghcOptDebugInfo opts) of - Nothing -> [] - Just NoDebugInfo -> [] - Just MinimalDebugInfo -> ["-g1"] - Just NormalDebugInfo -> ["-g2"] - Just MaximalDebugInfo -> ["-g3"] - - , [ "-prof" | flagBool ghcOptProfilingMode ] - - , case flagToMaybe (ghcOptProfilingAuto opts) of - _ | not (flagBool ghcOptProfilingMode) - -> [] - Nothing -> [] - Just GhcProfAutoAll - | flagProfAuto implInfo -> ["-fprof-auto"] - | otherwise -> ["-auto-all"] -- not the same, but close - Just GhcProfAutoToplevel - | flagProfAuto implInfo -> ["-fprof-auto-top"] - | otherwise -> ["-auto-all"] - Just GhcProfAutoExported - | flagProfAuto implInfo -> ["-fprof-auto-exported"] - | otherwise -> ["-auto"] - - , [ "-split-sections" | flagBool ghcOptSplitSections ] - , [ "-split-objs" | flagBool ghcOptSplitObjs ] - - , case flagToMaybe (ghcOptHPCDir opts) of - Nothing -> [] - Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir] - - , if parmakeSupported comp - then case ghcOptNumJobs opts of - NoFlag -> [] - Flag n -> ["-j" ++ maybe "" show n] - else [] - - -------------------- - -- Creating libraries - - , [ "-staticlib" | flagBool ghcOptStaticLib ] - , [ "-shared" | flagBool ghcOptShared ] - , case flagToMaybe (ghcOptDynLinkMode opts) of - Nothing -> [] - Just GhcStaticOnly -> ["-static"] - Just GhcDynamicOnly -> ["-dynamic"] - Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] - , [ "-fPIC" | flagBool ghcOptFPic ] - - , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ] - - ------------------------ - -- Redirecting outputs - - , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ] - , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ] - , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ] - , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ] - , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ] - , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ] - , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ] - , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ] - - ----------------------- - -- Source search path - - , [ "-i" | flagBool ghcOptSourcePathClear ] - , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] - - -------------------- - - -------------------- - -- CPP, C, and C++ stuff - - , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ] - , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts] - , concat [ [ "-optP-include", "-optP" ++ inc] - | inc <- flags ghcOptCppIncludes ] - , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts] - , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc - let cxxflag = case compilerCompatVersion GHC comp of - Just v | v >= mkVersion [8, 10] -> "-optcxx" - _ -> "-optc" - in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts] - , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts] - - ----------------- - -- Linker stuff - - , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts] - , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] - , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ] - , if isOSX - then concat [ ["-framework", fmwk] - | fmwk <- flags ghcOptLinkFrameworks ] - else [] - , if isOSX - then concat [ ["-framework-path", path] - | path <- flags ghcOptLinkFrameworkDirs ] - else [] - , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ] - , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ] - , concat [ [ "-optl-Wl,-rpath," ++ dir] - | dir <- flags ghcOptRPaths ] - , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ] - - ------------- - -- Packages - - , concat [ [ case () of - _ | unitIdSupported comp -> "-this-unit-id" - | packageKeySupported comp -> "-this-package-key" - | otherwise -> "-package-name" - , this_arg ] - | this_arg <- flag ghcOptThisUnitId ] - - , concat [ ["-this-component-id", prettyShow this_cid ] - | this_cid <- flag ghcOptThisComponentId ] - - , if null (ghcOptInstantiatedWith opts) - then [] - else "-instantiated-with" - : intercalate "," (map (\(n,m) -> prettyShow n ++ "=" - ++ prettyShow m) - (ghcOptInstantiatedWith opts)) - : [] - - , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ] - - , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ] - , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ] - , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ] - - , packageDbArgs implInfo (ghcOptPackageDBs opts) - - , concat $ let space "" = "" - space xs = ' ' : xs - in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] - | (ipkgid,rns) <- flags ghcOptPackages ] - - ---------------------------- - -- Language and extensions - - , if supportsHaskell2010 implInfo - then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ] - else [] - - , [ ext' - | ext <- flags ghcOptExtensions - , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of - Just (Just arg) -> [arg] - Just Nothing -> [] - Nothing -> - error $ "Distribution.Simple.Program.GHC.renderGhcOptions: " - ++ prettyShow ext ++ " not present in ghcOptExtensionMap." - ] - - ---------------- - -- GHCi - - , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts - , flagGhciScript implInfo ] - - --------------- - -- Inputs - - -- Specify the input file(s) first, so that in ghci the `main-is` module is - -- in scope instead of the first module defined in `other-modules`. - , flags ghcOptInputFiles - , [ prettyShow modu | modu <- flags ghcOptInputModules ] - - , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] - , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] - - --------------- - -- Extra - - , ghcOptExtra opts - - ] - - - where - implInfo = getImplInfo comp - isOSX = os == OSX - flag flg = flagToList (flg opts) - flags flg = fromNubListR . flg $ opts - flagBool flg = fromFlagOrDefault False (flg opts) - -verbosityOpts :: Verbosity -> [String] -verbosityOpts verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - - --- | GHC <7.6 uses '-package-conf' instead of '-package-db'. -packageDbArgsConf :: PackageDBStack -> [String] -packageDbArgsConf dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> ("-no-user-package-conf") - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error $ "internal error: unexpected package db stack: " - ++ show dbstack - --- | GHC >= 7.6 uses the '-package-db' flag. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. -packageDbArgsDb :: PackageDBStack -> [String] --- special cases to make arguments prettier in common scenarios -packageDbArgsDb dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) - | all isSpecific dbs -> concatMap single dbs - (GlobalPackageDB:dbs) - | all isSpecific dbs -> "-no-user-package-db" - : concatMap single dbs - dbs -> "-clear-package-db" - : concatMap single dbs - where - single (SpecificPackageDB db) = [ "-package-db", db ] - single GlobalPackageDB = [ "-global-package-db" ] - single UserPackageDB = [ "-user-package-db" ] - isSpecific (SpecificPackageDB _) = True - isSpecific _ = False - -packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String] -packageDbArgs implInfo - | flagPackageConf implInfo = packageDbArgsConf - | otherwise = packageDbArgsDb +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Distribution.Simple.Program.GHC + ( GhcOptions (..) + , GhcMode (..) + , GhcOptimisation (..) + , GhcDynLinkMode (..) + , GhcProfAuto (..) + , ghcInvocation + , renderGhcOptions + , runGHC + , runGHCWithResponseFile + , runReplProgram + , packageDbArgsDb + , normaliseGhcArgs + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Backpack +import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..)) +import Distribution.ModuleName +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.GHC.ImplInfo +import Distribution.Simple.Program.Find (getExtraPathEnv) +import Distribution.Simple.Program.ResponseFile +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Types +import Distribution.Simple.Utils (TempFileOptions, infoNoWrap) +import Distribution.System +import Distribution.Types.ComponentId +import Distribution.Types.ParStrat +import Distribution.Utils.NubList +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version + +import GHC.IO.Encoding (TextEncoding) +import Language.Haskell.Extension + +import Data.List (stripPrefix) +import qualified Data.Map as Map +import Data.Monoid (All (..), Any (..), Endo (..)) +import qualified Data.Set as Set +import qualified System.Process as Process + +normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String] +normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs + | ghcVersion `withinRange` supportedGHCVersions = + argumentFilters . filter simpleFilters . filterRtsArgs $ ghcArgs + where + supportedGHCVersions :: VersionRange + supportedGHCVersions = orLaterVersion (mkVersion [8, 0]) + -- we (weakly) support unknown future GHC versions for the purpose + -- of filtering GHC arguments + + from :: Monoid m => [Int] -> m -> m + from version flags + | ghcVersion `withinRange` orLaterVersion (mkVersion version) = flags + | otherwise = mempty + + to :: Monoid m => [Int] -> m -> m + to version flags + | ghcVersion `withinRange` earlierVersion (mkVersion version) = flags + | otherwise = mempty + + checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m + checkGhcFlags fun = + mconcat + [ fun ghcArgs + , checkComponentFlags libBuildInfo pkgLibs + , checkComponentFlags buildInfo executables + , checkComponentFlags testBuildInfo testSuites + , checkComponentFlags benchmarkBuildInfo benchmarks + ] + where + pkgLibs = maybeToList library ++ subLibraries + + checkComponentFlags :: (a -> BuildInfo) -> [a] -> m + checkComponentFlags getInfo = foldMap (checkComponent . getInfo) + where + checkComponent :: BuildInfo -> m + checkComponent = foldMap fun . filterGhcOptions . allGhcOptions + + allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])] + allGhcOptions = + foldMap + (perCompilerFlavorToList .) + [options, profOptions, sharedOptions, staticOptions] + + filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]] + filterGhcOptions l = [opts | (GHC, opts) <- l] + + safeToFilterWarnings :: Bool + safeToFilterWarnings = getAll $ checkGhcFlags checkWarnings + where + checkWarnings :: [String] -> All + checkWarnings = All . Set.null . foldr alter Set.empty + + alter :: String -> Set String -> Set String + alter flag = + appEndo $ + mconcat + [ \s -> Endo $ if s == "-Werror" then Set.insert s else id + , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id + , \s -> + from [8, 6] . Endo $ + if s == "-Werror=compat" + then Set.union compatWarningSet + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wno-error=compat" + then (`Set.difference` compatWarningSet) + else id + , \s -> + from [8, 6] . Endo $ + if s == "-Wwarn=compat" + then (`Set.difference` compatWarningSet) + else id + , from [8, 4] $ markFlag "-Werror=" Set.insert + , from [8, 4] $ markFlag "-Wwarn=" Set.delete + , from [8, 4] $ markFlag "-Wno-error=" Set.delete + ] + flag + + markFlag + :: String + -> (String -> Set String -> Set String) + -> String + -> Endo (Set String) + markFlag name update flag = Endo $ case stripPrefix name flag of + Just rest | not (null rest) && rest /= "compat" -> update rest + _ -> id + + flagArgumentFilter :: [String] -> [String] -> [String] + flagArgumentFilter flags = go + where + makeFilter :: String -> String -> Option' (First' ([String] -> [String])) + makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg + where + filterRest leftOver = case dropEq leftOver of + [] -> drop 1 + _ -> id + + checkFilter :: String -> Maybe ([String] -> [String]) + checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags + + go :: [String] -> [String] + go [] = [] + go (arg : args) = case checkFilter arg of + Just f -> go (f args) + Nothing -> arg : go args + + argumentFilters :: [String] -> [String] + argumentFilters = + flagArgumentFilter + ["-ghci-script", "-H", "-interactive-print"] + + -- \| Remove RTS arguments from a list. + filterRtsArgs :: [String] -> [String] + filterRtsArgs = snd . splitRTSArgs + + simpleFilters :: String -> Bool + simpleFilters = + not + . getAny + . mconcat + [ flagIn simpleFlags + , Any . isPrefixOf "-ddump-" + , Any . isPrefixOf "-dsuppress-" + , Any . isPrefixOf "-dno-suppress-" + , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"] + , flagIn . invertibleFlagSet "-f" . mconcat $ + [ + [ "reverse-errors" + , "warn-unused-binds" + , "break-on-error" + , "break-on-exception" + , "print-bind-result" + , "print-bind-contents" + , "print-evld-with-show" + , "implicit-import-qualified" + , "error-spans" + ] + , from + [7, 8] + [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options + , "print-explicit-kinds" + ] + , from + [8, 0] + [ "print-explicit-coercions" + , "print-explicit-runtime-reps" + , "print-equality-relations" + , "print-unicode-syntax" + , "print-expanded-synonyms" + , "print-potential-instances" + , "print-typechecker-elaboration" + ] + , from + [8, 2] + [ "diagnostics-show-caret" + , "local-ghci-history" + , "show-warning-groups" + , "hide-source-paths" + , "show-hole-constraints" + ] + , from [8, 4] ["show-loaded-modules"] + , from [8, 6] ["ghci-leak-check", "no-it"] + , from + [8, 10] + [ "defer-diagnostics" -- affects printing of diagnostics + , "keep-going" -- try harder, the build will still fail if it's erroneous + , "print-axiom-incomps" -- print more debug info for closed type families + ] + , from + [9, 2] + [ "family-application-cache" + ] + , from + [9, 6] + [ "print-redundant-promotion-ticks" + , "show-error-context" + ] + , from + [9, 8] + [ "unoptimized-core-for-interpreter" + ] + , from + [9, 10] + [ "diagnostics-as-json" + , "print-error-index-links" + , "break-points" + ] + ] + , flagIn $ invertibleFlagSet "-d" ["ppr-case-as-let", "ppr-ticks"] + , isOptIntFlag + , isIntFlag + , if safeToFilterWarnings + then isWarning <> (Any . ("-w" ==)) + else mempty + , from [8, 6] $ + if safeToFilterHoles + then isTypedHoleFlag + else mempty + ] + + flagIn :: Set String -> String -> Any + flagIn set flag = Any $ Set.member flag set + + isWarning :: String -> Any + isWarning = + mconcat $ + map + ((Any .) . isPrefixOf) + ["-fwarn-", "-fno-warn-", "-W", "-Wno-"] + + simpleFlags :: Set String + simpleFlags = + Set.fromList . mconcat $ + [ + [ "-n" + , "-#include" + , "-Rghc-timing" + , "-dstg-stats" + , "-dth-dec-file" + , "-dsource-stats" + , "-dverbose-core2core" + , "-dverbose-stg2stg" + , "-dcore-lint" + , "-dstg-lint" + , "-dcmm-lint" + , "-dasm-lint" + , "-dannot-lint" + , "-dshow-passes" + , "-dfaststring-stats" + , "-fno-max-relevant-binds" + , "-recomp" + , "-no-recomp" + , "-fforce-recomp" + , "-fno-force-recomp" + ] + , from + [8, 2] + [ "-fno-max-errors" + , "-fdiagnostics-color=auto" + , "-fdiagnostics-color=always" + , "-fdiagnostics-color=never" + , "-dppr-debug" + , "-dno-debug-output" + ] + , from [8, 4] ["-ddebug-output"] + , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"] + , from [8, 6] ["-dhex-word-literals"] + , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"] + , from [9, 0] ["-dlinear-core-lint"] + , from [9, 10] ["-dipe-stats"] + ] + + isOptIntFlag :: String -> Any + isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"] + + isIntFlag :: String -> Any + isIntFlag = + mconcat . map (dropIntFlag False) . mconcat $ + [ + [ "-fmax-relevant-binds" + , "-ddpr-user-length" + , "-ddpr-cols" + , "-dtrace-level" + , "-fghci-hist-size" + , "-dinitial-unique" + , "-dunique-increment" + ] + , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"] + , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"] + , from [9, 12] ["-fmax-forced-spec-args", "-fwrite-if-compression"] + ] + + dropIntFlag :: Bool -> String -> String -> Any + dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of + Nothing -> False + Just rest + | isOpt && null rest -> True + | otherwise -> case parseInt rest of + Just _ -> True + Nothing -> False + where + parseInt :: String -> Maybe Int + parseInt = readMaybe . dropEq + + dropEq :: String -> String + dropEq ('=' : s) = s + dropEq s = s + + invertibleFlagSet :: String -> [String] -> Set String + invertibleFlagSet prefix flagNames = + Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames + + compatWarningSet :: Set String + compatWarningSet = + Set.fromList $ + mconcat + [ from + [8, 6] + [ "missing-monadfail-instances" + , "semigroup" + , "noncanonical-monoid-instances" + , "implicit-kind-vars" + ] + ] + + safeToFilterHoles :: Bool + safeToFilterHoles = + getAll . checkGhcFlags $ + All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred + where + notDeferred :: String -> Option' (Last' Bool) + notDeferred "-fdefer-typed-holes" = Option' . Just . Last' $ False + notDeferred "-fno-defer-typed-holes" = Option' . Just . Last' $ True + notDeferred _ = Option' Nothing + + isTypedHoleFlag :: String -> Any + isTypedHoleFlag = + mconcat + [ flagIn . invertibleFlagSet "-f" $ + [ "show-hole-constraints" + , "show-valid-substitutions" + , "show-valid-hole-fits" + , "sort-valid-hole-fits" + , "sort-by-size-hole-fits" + , "sort-by-subsumption-hole-fits" + , "abstract-refinement-hole-fits" + , "show-provenance-of-hole-fits" + , "show-hole-matches-of-hole-fits" + , "show-type-of-hole-fits" + , "show-type-app-of-hole-fits" + , "show-type-app-vars-of-hole-fits" + , "unclutter-valid-hole-fits" + ] + , flagIn . Set.fromList $ + [ "-fno-max-valid-hole-fits" + , "-fno-max-refinement-hole-fits" + , "-fno-refinement-level-hole-fits" + ] + , mconcat . map (dropIntFlag False) $ + [ "-fmax-valid-hole-fits" + , "-fmax-refinement-hole-fits" + , "-frefinement-level-hole-fits" + ] + ] +normaliseGhcArgs _ _ args = args + +-- | A structured set of GHC options/flags +-- +-- Note that options containing lists fall into two categories: +-- +-- * options that can be safely deduplicated, e.g. input modules or +-- enabled extensions; +-- * options that cannot be deduplicated in general without changing +-- semantics, e.g. extra ghc options or linking options. +data GhcOptions = GhcOptions + { ghcOptMode :: Flag GhcMode + -- ^ The major mode for the ghc invocation. + , ghcOptExtra :: [String] + -- ^ Any extra options to pass directly to ghc. These go at the end and hence + -- override other stuff. + , ghcOptExtraDefault :: [String] + -- ^ Extra default flags to pass directly to ghc. These go at the beginning + -- and so can be overridden by other stuff. + , ----------------------- + -- Inputs and outputs + + ghcOptInputFiles :: NubListR (SymbolicPath Pkg File) + -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode. + , ghcOptInputScripts :: NubListR (SymbolicPath Pkg File) + -- ^ Script files with irregular extensions that need -x hs. + , ghcOptInputModules :: NubListR ModuleName + -- ^ The names of input Haskell modules, mainly for @--make@ mode. + , ghcOptOutputFile :: Flag (SymbolicPath Pkg File) + -- ^ Location for output file; the @ghc -o@ flag. + , ghcOptOutputDynFile :: Flag FilePath + -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode; + -- the @ghc -dyno@ flag. + , ghcOptSourcePathClear :: Flag Bool + -- ^ Start with an empty search path for Haskell source files; + -- the @ghc -i@ flag (@-i@ on its own with no path argument). + , ghcOptSourcePath :: NubListR (SymbolicPath Pkg (Dir Source)) + -- ^ Search path for Haskell source files; the @ghc -i@ flag. + , ghcOptUnitFiles :: [FilePath] + -- ^ Unit files to load; the @ghc -unit@ flag. + , ------------- + -- Packages + + ghcOptThisUnitId :: Flag String + -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@ + -- flag (or @-this-package-key@ or @-package-name@ on older + -- versions of GHC). This is a 'String' because we assume you've + -- already figured out what the correct format for this string is + -- (we need to handle backwards compatibility.) + , ghcOptThisComponentId :: Flag ComponentId + -- ^ GHC doesn't make any assumptions about the format of + -- definite unit ids, so when we are instantiating a package it + -- needs to be told explicitly what the component being instantiated + -- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty + , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the requirements of the package being compiled are to + -- be filled. When typechecking an indefinite package, the 'OpenModule' + -- is always a 'OpenModuleVar'; otherwise, it specifies the installed module + -- that instantiates a package. + , ghcOptNoCode :: Flag Bool + -- ^ No code? (But we turn on interface writing + , ghcOptPackageDBs :: PackageDBStack + -- ^ GHC package databases to use, the @ghc -package-conf@ flag. + , ghcOptPackages + :: NubListR (OpenUnitId, ModuleRenaming) + -- ^ The GHC packages to bring into scope when compiling, + -- the @ghc -package-id@ flags. + , ghcOptHideAllPackages :: Flag Bool + -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag + , ghcOptWarnMissingHomeModules :: Flag Bool + -- ^ Warn about modules, not listed in command line + , ghcOptNoAutoLinkPackages :: Flag Bool + -- ^ Don't automatically link in Haskell98 etc; the @ghc + -- -no-auto-link-packages@ flag. + , ----------------- + -- Linker stuff + + ghcOptLinkLibs :: [FilePath] + -- ^ Names of libraries to link in; the @ghc -l@ flag. + , ghcOptLinkLibPath :: NubListR (SymbolicPath Pkg (Dir Lib)) + -- ^ Search path for libraries to link in; the @ghc -L@ flag. + , ghcOptLinkOptions :: [String] + -- ^ Options to pass through to the linker; the @ghc -optl@ flag. + , ghcOptLinkFrameworks :: NubListR String + -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag. + , ghcOptLinkFrameworkDirs :: NubListR (SymbolicPath Pkg (Dir Framework)) + -- ^ OSX only: Search path for frameworks to link in; the + -- @ghc -framework-path@ flag. + , ghcOptLinkRts :: Flag Bool + -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library. + , ghcOptNoLink :: Flag Bool + -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag. + , ghcOptLinkNoHsMain :: Flag Bool + -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ + -- flag. + , ghcOptLinkModDefFiles :: NubListR FilePath + -- ^ Module definition files (Windows specific) + , -------------------- + -- C and CPP stuff + + ghcOptCcOptions :: [String] + -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag. + , ghcOptCxxOptions :: [String] + -- ^ Options to pass through to the C++ compiler. + , ghcOptAsmOptions :: [String] + -- ^ Options to pass through to the Assembler. + , ghcOptCppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optP@ flag. + , ghcOptJSppOptions :: [String] + -- ^ Options to pass through to CPP; the @ghc -optJSP@ flag. @since 3.16.0.0 + , ghcOptCppIncludePath :: NubListR (SymbolicPath Pkg (Dir Include)) + -- ^ Search path for CPP includes like header files; the @ghc -I@ flag. + , ghcOptCppIncludes :: NubListR (SymbolicPath Pkg File) + -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag. + , ghcOptFfiIncludes :: NubListR FilePath + -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag. + , ghcOptCcProgram :: Flag FilePath + -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag. + , ---------------------------- + -- Language and extensions + + ghcOptLanguage :: Flag Language + -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. + , ghcOptExtensions :: NubListR Extension + -- ^ The language extensions; the @ghc -X@ flag. + , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag) + -- ^ A GHC version-dependent mapping of extensions to flags. This must be + -- set to be able to make use of the 'ghcOptExtensions'. + , ---------------- + -- Compilation + + ghcOptOptimisation :: Flag GhcOptimisation + -- ^ What optimisation level to use; the @ghc -O@ flag. + , ghcOptDebugInfo :: Flag DebugInfoLevel + -- ^ Emit debug info; the @ghc -g@ flag. + , ghcOptProfilingMode :: Flag Bool + -- ^ Compile in profiling mode; the @ghc -prof@ flag. + , ghcOptProfilingAuto :: Flag GhcProfAuto + -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags. + , ghcOptSplitSections :: Flag Bool + -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag. + , ghcOptSplitObjs :: Flag Bool + -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag. + , ghcOptNumJobs :: Flag ParStrat + -- ^ Run N jobs simultaneously (if possible). + , ghcOptHPCDir :: Flag (SymbolicPath Pkg (Dir Mix)) + -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. + , ---------------- + -- GHCi + + ghcOptGHCiScripts :: [FilePath] + -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag + , ------------------------ + -- Redirecting outputs + + ghcOptHiSuffix :: Flag String + , ghcOptObjSuffix :: Flag String + , ghcOptDynHiSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptDynObjSuffix :: Flag String + -- ^ only in 'GhcStaticAndDynamic' mode + , ghcOptHiDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptHieDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptObjDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptOutputDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , ghcOptStubDir :: Flag (SymbolicPath Pkg (Dir Artifacts)) + , -------------------- + -- Creating libraries + + ghcOptDynLinkMode :: Flag GhcDynLinkMode + , ghcOptStaticLib :: Flag Bool + , ghcOptShared :: Flag Bool + , ghcOptFPic :: Flag Bool + , ghcOptDylibName :: Flag String + , ghcOptRPaths :: NubListR FilePath + , --------------- + -- Misc flags + + ghcOptVerbosity :: Flag Verbosity + -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. + , ghcOptExtraPath :: NubListR (SymbolicPath Pkg (Dir Build)) + -- ^ Put the extra folders in the PATH environment variable we invoke + -- GHC with + , ghcOptCabal :: Flag Bool + -- ^ Let GHC know that it is Cabal that's calling it. + -- Modifies some of the GHC error messages. + } + deriving (Show, Generic) + +data GhcMode + = -- | @ghc -c@ + GhcModeCompile + | -- | @ghc@ + GhcModeLink + | -- | @ghc --make@ + GhcModeMake + | -- | @ghci@ \/ @ghc --interactive@ + GhcModeInteractive + | -- | @ghc --abi-hash@ + -- | GhcModeDepAnalysis -- ^ @ghc -M@ + -- | GhcModeEvaluate -- ^ @ghc -e@ + GhcModeAbiHash + deriving (Show, Eq) + +data GhcOptimisation + = -- | @-O0@ + GhcNoOptimisation + | -- | @-O@ + GhcNormalOptimisation + | -- | @-O2@ + GhcMaximumOptimisation + | -- | e.g. @-Odph@ + GhcSpecialOptimisation String + deriving (Show, Eq) + +data GhcDynLinkMode + = -- | @-static@ + GhcStaticOnly + | -- | @-dynamic@ + GhcDynamicOnly + | -- | @-static -dynamic-too@ + GhcStaticAndDynamic + deriving (Show, Eq) + +data GhcProfAuto + = -- | @-fprof-auto@ + GhcProfAutoAll + | -- | @-fprof-auto-top@ + GhcProfAutoToplevel + | -- | @-fprof-auto-exported@ + GhcProfAutoExported + | -- | @-fprof-late + GhcProfLate + deriving (Show, Eq) + +runGHC + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHC verbosity ghcProg comp platform mbWorkDir opts = do + runProgramInvocation verbosity + =<< ghcInvocation verbosity ghcProg comp platform mbWorkDir opts + +runGHCWithResponseFile + :: FilePath + -> Maybe TextEncoding + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runGHCWithResponseFile fileNameTemplate encoding tempFileOptions verbosity ghcProg comp platform maybeWorkDir opts = do + invocation <- ghcInvocation verbosity ghcProg comp platform maybeWorkDir opts + + let compilerSupportsResponseFiles = + case compilerCompatVersion GHC comp of + -- GHC 9.4 is the first version which supports response files. + Just version -> version >= mkVersion [9, 4] + Nothing -> False + + args = progInvokeArgs invocation + + if not compilerSupportsResponseFiles + then runProgramInvocation verbosity invocation + else do + let (rtsArgs, otherArgs) = splitRTSArgs args + + withResponseFile + verbosity + tempFileOptions + fileNameTemplate + encoding + otherArgs + $ \responseFile -> do + let newInvocation = + invocation{progInvokeArgs = ('@' : responseFile) : rtsArgs} + + infoNoWrap verbosity $ + "GHC response file arguments: " + <> case otherArgs of + [] -> "" + arg : args' -> Process.showCommandForUser arg args' + + runProgramInvocation verbosity newInvocation + +-- Note [Make --interactive the first argument to GHC] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The ghc argument @--interactive@ needs to be the first argument to the +-- ghc invocation, because Haskell Language Server used to rely on this. +-- This was initially changed for Cabal 3.16, but it broke all existing Haskell +-- Language Server prebuilt binaries. +-- To avoid this, we uphold this assumption in Haskell Language Server until the next +-- Cabal release (3.18). +-- +-- The solution is to make sure that @--interactive@ is not passed as an argument in +-- the response file that is usually passed to ghc. +-- Instead, we filter out @--interactive@ and always pass it as the first argument, +-- if it exists. +-- +-- We plan to remove this Hack in Cabal 3.18. + +-- Start the repl. Either use `ghc`, or the program specified by the --with-repl flag. +runReplProgram + :: Maybe FilePath + -- ^ --with-repl argument + -> TempFileOptions + -> Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO () +runReplProgram withReplProg _tempFileOptions verbosity ghcProg comp platform mbWorkDir ghcOpts = + let replProg = case withReplProg of + Just path -> ghcProg{programLocation = FoundOnSystem path} + Nothing -> ghcProg + in do + -- in runGHCWithResponseFile "ghci.rsp" Nothing tempFileOptions verbosity replProg comp platform mbWorkDir ghcOpts + -- See Note [Make --interactive the first argument to GHC] + -- In Cabal 3.18, restore the line above. + invocation <- ghcInvocation verbosity replProg comp platform mbWorkDir ghcOpts + let invocation' = + let + argsWithoutInteractive = filter (/= "--interactive") (progInvokeArgs invocation) + in + invocation + { progInvokeArgs = ["--interactive"] <> argsWithoutInteractive + } + runProgramInvocation verbosity invocation' + +ghcInvocation + :: Verbosity + -> ConfiguredProgram + -> Compiler + -> Platform + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> GhcOptions + -> IO ProgramInvocation +ghcInvocation verbosity ghcProg comp platform mbWorkDir opts = do + -- NOTE: GHC is the only program whose path we modify with more values than + -- the standard @extra-prog-path@, namely the folders of the executables in + -- the components, see @componentGhcOptions@. + let envOverrides = programOverrideEnv ghcProg + extraPath <- + getExtraPathEnv verbosity envOverrides $ + map getSymbolicPath $ + fromNubListR $ + ghcOptExtraPath opts + let ghcProg' = ghcProg{programOverrideEnv = envOverrides ++ extraPath} + return $ + programInvocationCwd mbWorkDir ghcProg' $ + renderGhcOptions comp platform opts + +-- TODO: use the -working-dir GHC flag instead of setting the process +-- working directory, as this improves error messages. + +renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] +renderGhcOptions comp _platform@(Platform _arch os) opts + | compilerFlavor comp `notElem` [GHC, GHCJS] = + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ "compiler flavor must be 'GHC' or 'GHCJS'!" + | otherwise = + concat + [ case flagToMaybe (ghcOptMode opts) of + Nothing -> [] + Just GhcModeCompile -> ["-c"] + Just GhcModeLink -> [] + Just GhcModeMake -> ["--make"] + Just GhcModeInteractive -> ["--interactive"] + Just GhcModeAbiHash -> ["--abi-hash"] + , -- Just GhcModeDepAnalysis -> ["-M"] + -- Just GhcModeEvaluate -> ["-e", expr] + + ghcOptExtraDefault opts + , ["-no-link" | flagBool ghcOptNoLink] + , ["-flink-rts" | flagBool ghcOptLinkRts] + , --------------- + -- Misc flags + + maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) + , ["-fbuilding-cabal-package" | flagBool ghcOptCabal] + , ---------------- + -- Compilation + + case flagToMaybe (ghcOptOptimisation opts) of + Nothing -> [] + Just GhcNoOptimisation -> ["-O0"] + Just GhcNormalOptimisation -> ["-O"] + Just GhcMaximumOptimisation -> ["-O2"] + Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph + , case flagToMaybe (ghcOptDebugInfo opts) of + Nothing -> [] + Just NoDebugInfo -> [] + Just MinimalDebugInfo -> ["-g1"] + Just NormalDebugInfo -> ["-g2"] + Just MaximalDebugInfo -> ["-g3"] + , ["-prof" | flagBool ghcOptProfilingMode] + , case flagToMaybe (ghcOptProfilingAuto opts) of + _ + | not (flagBool ghcOptProfilingMode) -> + [] + Nothing -> [] + Just GhcProfAutoAll + | flagProfAuto implInfo -> ["-fprof-auto"] + | otherwise -> ["-auto-all"] -- not the same, but close + Just GhcProfLate + | flagProfLate implInfo -> ["-fprof-late"] + | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have. + Just GhcProfAutoToplevel + | flagProfAuto implInfo -> ["-fprof-auto-top"] + | otherwise -> ["-auto-all"] + Just GhcProfAutoExported + | flagProfAuto implInfo -> ["-fprof-auto-exported"] + | otherwise -> ["-auto"] + , ["-split-sections" | flagBool ghcOptSplitSections] + , case compilerCompatVersion GHC comp of + -- the -split-objs flag was removed in GHC 9.8 + Just ver | ver >= mkVersion [9, 8] -> [] + _ -> ["-split-objs" | flagBool ghcOptSplitObjs] + , case flagToMaybe (ghcOptHPCDir opts) of + Nothing -> [] + Just hpcdir -> ["-fhpc", "-hpcdir", u hpcdir] + , if parmakeSupported comp + then case ghcOptNumJobs opts of + NoFlag -> [] + Flag Serial -> [] + Flag (UseSem name) -> + if jsemSupported comp + then ["-jsem " ++ name] + else [] + Flag (NumJobs n) -> ["-j" ++ maybe "" show n] + else [] + , -------------------- + -- Creating libraries + + ["-staticlib" | flagBool ghcOptStaticLib] + , ["-shared" | flagBool ghcOptShared] + , case flagToMaybe (ghcOptDynLinkMode opts) of + Nothing -> [] + Just GhcStaticOnly -> ["-static"] + Just GhcDynamicOnly -> ["-dynamic"] + Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"] + , ["-fPIC" | flagBool ghcOptFPic] + , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName] + , ------------------------ + -- Redirecting outputs + + concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix] + , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix] + , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix] + , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix] + , concat [["-outputdir", u dir] | dir <- flag ghcOptOutputDir] + , concat [["-odir", u dir] | dir <- flag ghcOptObjDir] + , concat [["-hidir", u dir] | dir <- flag ghcOptHiDir] + , concat [["-hiedir", u dir] | dir <- flag ghcOptHieDir] + , concat [["-stubdir", u dir] | dir <- flag ghcOptStubDir] + , ----------------------- + -- Source search path + + ["-i" | flagBool ghcOptSourcePathClear] + , ["-i" ++ u dir | dir <- flags ghcOptSourcePath] + , -------------------- + + -------------------- + -- CPP, C, and C++ stuff + + ["-I" ++ u dir | dir <- flags ghcOptCppIncludePath] + , ["-optP" ++ opt | opt <- ghcOptCppOptions opts] + , ["-optJSP" ++ opt | opt <- ghcOptJSppOptions opts] + , concat + [ ["-optP-include", "-optP" ++ u inc] + | inc <- flags ghcOptCppIncludes + ] + , ["-optc" ++ opt | opt <- ghcOptCcOptions opts] + , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc + let cxxflag = case compilerCompatVersion GHC comp of + Just v | v >= mkVersion [8, 10] -> "-optcxx" + _ -> "-optc" + in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts] + , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts] + , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram] + , ----------------- + -- Linker stuff + + ["-optl" ++ opt | opt <- ghcOptLinkOptions opts] + , ["-l" ++ lib | lib <- ghcOptLinkLibs opts] + , ["-L" ++ u dir | dir <- flags ghcOptLinkLibPath] + , if isOSX + then + concat + [ ["-framework", fmwk] + | fmwk <- flags ghcOptLinkFrameworks + ] + else [] + , if isOSX + then + concat + [ ["-framework-path", u path] + | path <- flags ghcOptLinkFrameworkDirs + ] + else [] + , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain] + , ["-dynload deploy" | not (null (flags ghcOptRPaths))] + , ["-optl-Wl,-rpath," ++ dir | dir <- flags ghcOptRPaths] + , flags ghcOptLinkModDefFiles + , ------------- + -- Packages + + concat + [ [ if + | unitIdSupported comp -> "-this-unit-id" + | packageKeySupported comp -> "-this-package-key" + | otherwise -> "-package-name" + , this_arg + ] + | this_arg <- flag ghcOptThisUnitId + ] + , concat + [ ["-this-component-id", prettyShow this_cid] + | this_cid <- flag ghcOptThisComponentId + ] + , if null (ghcOptInstantiatedWith opts) + then [] + else + "-instantiated-with" + : intercalate + "," + ( map + ( \(n, m) -> + prettyShow n + ++ "=" + ++ prettyShow m + ) + (ghcOptInstantiatedWith opts) + ) + : [] + , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode] + , ["-hide-all-packages" | flagBool ghcOptHideAllPackages] + , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules] + , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages] + , packageDbArgs implInfo (interpretPackageDBStack Nothing (ghcOptPackageDBs opts)) + , concat $ + let space "" = "" + space xs = ' ' : xs + in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)] + | (ipkgid, rns) <- flags ghcOptPackages + ] + , ---------------------------- + -- Language and extensions + + if supportsHaskell2010 implInfo + then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage] + else [] + , [ ext' + | ext <- flags ghcOptExtensions + , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of + Just (Just arg) -> [arg] + Just Nothing -> [] + Nothing -> + error $ + "Distribution.Simple.Program.GHC.renderGhcOptions: " + ++ prettyShow ext + ++ " not present in ghcOptExtensionMap." + ] + , ---------------- + -- GHCi + + concat + [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo + ] + , --------------- + -- Inputs + + -- Specify the input file(s) first, so that in ghci the `main-is` module is + -- in scope instead of the first module defined in `other-modules`. + map u $ flags ghcOptInputFiles + , concat [["-x", "hs", u script] | script <- flags ghcOptInputScripts] + , [prettyShow modu | modu <- flags ghcOptInputModules] + , concat [["-o", u out] | out <- flag ghcOptOutputFile] + , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile] + , -- unit files + concat [["-unit", "@" ++ unit] | unit <- ghcOptUnitFiles opts] + , --------------- + -- Extra + + ghcOptExtra opts + ] + where + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + implInfo = getImplInfo comp + isOSX = os == OSX + flag flg = flagToList (flg opts) + flags flg = fromNubListR . flg $ opts + flagBool flg = fromFlagOrDefault False (flg opts) + +verbosityOpts :: Verbosity -> [String] +verbosityOpts verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +-- | GHC <7.6 uses '-package-conf' instead of '-package-db'. +packageDbArgsConf :: PackageDBStackCWD -> [String] +packageDbArgsConf dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs + (GlobalPackageDB : dbs) -> + ("-no-user-package-conf") + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = ["-package-conf", db] + specific _ = ierror + ierror = + error $ + "internal error: unexpected package db stack: " + ++ show dbstack + +-- | GHC >= 7.6 uses the '-package-db' flag. See +-- https://gitlab.haskell.org/ghc/ghc/-/issues/5977. +packageDbArgsDb :: PackageDBStackCWD -> [String] +-- special cases to make arguments prettier in common scenarios +packageDbArgsDb dbstack = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) + | all isSpecific dbs -> concatMap single dbs + (GlobalPackageDB : dbs) + | all isSpecific dbs -> + "-no-user-package-db" + : concatMap single dbs + dbs -> + "-clear-package-db" + : concatMap single dbs + where + single (SpecificPackageDB db) = ["-package-db", db] + single GlobalPackageDB = ["-global-package-db"] + single UserPackageDB = ["-user-package-db"] + isSpecific (SpecificPackageDB _) = True + isSpecific _ = False + +packageDbArgs :: GhcImplInfo -> PackageDBStackCWD -> [String] +packageDbArgs implInfo + | flagPackageConf implInfo = packageDbArgsConf + | otherwise = packageDbArgsDb + +-- | Split a list of command-line arguments into RTS arguments and non-RTS +-- arguments. +splitRTSArgs :: [String] -> ([String], [String]) +splitRTSArgs args = + let addRTSArg arg ~(rtsArgs, nonRTSArgs) = (arg : rtsArgs, nonRTSArgs) + addNonRTSArg arg ~(rtsArgs, nonRTSArgs) = (rtsArgs, arg : nonRTSArgs) + + go _ [] = ([], []) + go isRTSArg (arg : rest) = + case arg of + "+RTS" -> addRTSArg arg $ go True rest + "-RTS" -> addRTSArg arg $ go False rest + "--RTS" -> ([arg], rest) + "--" -> ([], arg : rest) + _ -> + if isRTSArg + then addRTSArg arg $ go isRTSArg rest + else addNonRTSArg arg $ go isRTSArg rest + in go False args -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions diff --git a/src/Distribution/Simple/Program/HcPkg.hs b/src/Distribution/Simple/Program/HcPkg.hs --- a/src/Distribution/Simple/Program/HcPkg.hs +++ b/src/Distribution/Simple/Program/HcPkg.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.HcPkg -- Copyright : Duncan Coutts 2009, 2013 @@ -13,35 +15,34 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and GHCJS have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - -- * Types - HcPkgInfo(..), - RegisterOptions(..), - defaultRegisterOptions, +module Distribution.Simple.Program.HcPkg + ( -- * Types + HcPkgInfo (..) + , RegisterOptions (..) + , defaultRegisterOptions -- * Actions - init, - invoke, - register, - unregister, - recache, - expose, - hide, - dump, - describe, - list, + , init + , invoke + , register + , unregister + , recache + , expose + , hide + , dump + , describe + , list -- * Program invocations - initInvocation, - registerInvocation, - unregisterInvocation, - recacheInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - describeInvocation, - listInvocation, + , initInvocation + , registerInvocation + , unregisterInvocation + , recacheInvocation + , exposeInvocation + , hideInvocation + , dumpInvocation + , describeInvocation + , listInvocation ) where import Distribution.Compat.Prelude hiding (init) @@ -51,245 +52,278 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Types.ComponentId import Distribution.Types.PackageId import Distribution.Types.UnitId +import Distribution.Utils.Path import Distribution.Verbosity -import Data.List (stripPrefix) -import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), ()) +import Data.List (stripPrefix) +import System.FilePath as FilePath + ( isPathSeparator + , joinPath + , splitDirectories + , splitPath + ) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.List.NonEmpty as NE import qualified System.FilePath.Posix as FilePath.Posix -- | Information about the features and capabilities of an @hc-pkg@ -- program. --- data HcPkgInfo = HcPkgInfo - { hcPkgProgram :: ConfiguredProgram - , noPkgDbStack :: Bool -- ^ no package DB stack supported - , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags - , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db - , supportsDirDbs :: Bool -- ^ supports directory style package databases - , requiresDirDbs :: Bool -- ^ requires directory style package databases - , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag - , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache - , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent + { hcPkgProgram :: ConfiguredProgram + , noPkgDbStack :: Bool + -- ^ no package DB stack supported + , noVerboseFlag :: Bool + -- ^ hc-pkg does not support verbosity flags + , flagPackageConf :: Bool + -- ^ use package-conf option instead of package-db + , supportsDirDbs :: Bool + -- ^ supports directory style package databases + , requiresDirDbs :: Bool + -- ^ requires directory style package databases + , nativeMultiInstance :: Bool + -- ^ supports --enable-multi-instance flag + , recacheMultiInstance :: Bool + -- ^ supports multi-instance via recache + , suppressFilesCheck :: Bool + -- ^ supports --force-files or equivalent } - -- | Call @hc-pkg@ to initialise a package database at the location {path}. -- -- > hc-pkg init {path} --- init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO () init hpi verbosity preferCompat path - | not (supportsDirDbs hpi) - || (not (requiresDirDbs hpi) && preferCompat) - = writeFile path "[]" - - | otherwise - = runProgramInvocation verbosity (initInvocation hpi verbosity path) + | not (supportsDirDbs hpi) + || (not (requiresDirDbs hpi) && preferCompat) = + writeFile path "[]" + | otherwise = + runProgramInvocation verbosity (initInvocation hpi verbosity path) -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. -invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO () -invoke hpi verbosity dbStack extraArgs = +invoke + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> [String] + -> IO () +invoke hpi verbosity mbWorkDir dbStack extraArgs = runProgramInvocation verbosity invocation where - args = packageDbStackOpts hpi dbStack ++ extraArgs - invocation = programInvocation (hcPkgProgram hpi) args + args = packageDbStackOpts hpi dbStack ++ extraArgs + invocation = programInvocationCwd mbWorkDir (hcPkgProgram hpi) args -- | Additional variations in the behaviour for 'register'. -data RegisterOptions = RegisterOptions { - -- | Allows re-registering \/ overwriting an existing package - registerAllowOverwrite :: Bool, - - -- | Insist on the ability to register multiple instances of a - -- single version of a single package. This will fail if the @hc-pkg@ - -- does not support it, see 'nativeMultiInstance' and - -- 'recacheMultiInstance'. - registerMultiInstance :: Bool, - - -- | Require that no checks are performed on the existence of package - -- files mentioned in the registration info. This must be used if - -- registering prior to putting the files in their final place. This will - -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. - registerSuppressFilesCheck :: Bool - } +data RegisterOptions = RegisterOptions + { registerAllowOverwrite :: Bool + -- ^ Allows re-registering \/ overwriting an existing package + , registerMultiInstance :: Bool + -- ^ Insist on the ability to register multiple instances of a + -- single version of a single package. This will fail if the @hc-pkg@ + -- does not support it, see 'nativeMultiInstance' and + -- 'recacheMultiInstance'. + , registerSuppressFilesCheck :: Bool + -- ^ Require that no checks are performed on the existence of package + -- files mentioned in the registration info. This must be used if + -- registering prior to putting the files in their final place. This will + -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'. + } -- | Defaults are @True@, @False@ and @False@ defaultRegisterOptions :: RegisterOptions -defaultRegisterOptions = RegisterOptions { - registerAllowOverwrite = True, - registerMultiInstance = False, - registerSuppressFilesCheck = False - } +defaultRegisterOptions = + RegisterOptions + { registerAllowOverwrite = True + , registerMultiInstance = False + , registerSuppressFilesCheck = False + } -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db] --- -register :: HcPkgInfo -> Verbosity -> PackageDBStack - -> InstalledPackageInfo - -> RegisterOptions - -> IO () -register hpi verbosity packagedbs pkgInfo registerOptions +register + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> RegisterOptions + -> IO () +register hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions | registerMultiInstance registerOptions - , not (nativeMultiInstance hpi || recacheMultiInstance hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "registering multiple instances of packages." - + , not (nativeMultiInstance hpi || recacheMultiInstance hpi) = + dieWithException verbosity RegMultipleInstancePkg | registerSuppressFilesCheck registerOptions - , not (suppressFilesCheck hpi) - = die' verbosity $ "HcPkg.register: the compiler does not support " - ++ "suppressing checks on files." - - -- This is a trick. Older versions of GHC do not support the - -- --enable-multi-instance flag for ghc-pkg register but it turns out that - -- the same ability is available by using ghc-pkg recache. The recache - -- command is there to support distro package managers that like to work - -- by just installing files and running update commands, rather than - -- special add/remove commands. So the way to register by this method is - -- to write the package registration file directly into the package db and - -- then call hc-pkg recache. - -- + , not (suppressFilesCheck hpi) = + dieWithException verbosity SuppressingChecksOnFile + -- This is a trick. Older versions of GHC do not support the + -- --enable-multi-instance flag for ghc-pkg register but it turns out that + -- the same ability is available by using ghc-pkg recache. The recache + -- command is there to support distro package managers that like to work + -- by just installing files and running update commands, rather than + -- special add/remove commands. So the way to register by this method is + -- to write the package registration file directly into the package db and + -- then call hc-pkg recache. + -- | registerMultiInstance registerOptions - , recacheMultiInstance hpi - = do let pkgdb = registrationPackageDB packagedbs - writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo - recache hpi verbosity pkgdb - - | otherwise - = runProgramInvocation verbosity - (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions) - -writeRegistrationFileDirectly :: Verbosity - -> HcPkgInfo - -> PackageDB - -> InstalledPackageInfo - -> IO () -writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo - | supportsDirDbs hpi - = do let pkgfile = dir prettyShow (installedUnitId pkgInfo) <.> "conf" - writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) - - | otherwise - = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs" - -writeRegistrationFileDirectly verbosity _ _ _ = - -- We don't know here what the dir for the global or user dbs are, - -- if that's needed it'll require a bit more plumbing to support. - die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now" + , recacheMultiInstance hpi = + do + let pkgdb = registrationPackageDB packagedbs + writeRegistrationFileDirectly verbosity hpi mbWorkDir pkgdb pkgInfo + recache hpi verbosity mbWorkDir pkgdb + | otherwise = + runProgramInvocation + verbosity + (registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions) +writeRegistrationFileDirectly + :: Verbosity + -> HcPkgInfo + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBS from + -> InstalledPackageInfo + -> IO () +writeRegistrationFileDirectly verbosity hpi mbWorkDir (SpecificPackageDB dir) pkgInfo + | supportsDirDbs hpi = + do + let pkgfile = interpretSymbolicPath mbWorkDir dir prettyShow (installedUnitId pkgInfo) <.> "conf" + writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo) + | otherwise = + dieWithException verbosity NoSupportDirStylePackageDb +writeRegistrationFileDirectly verbosity _ _ _ _ = + -- We don't know here what the dir for the global or user dbs are, + -- if that's needed it'll require a bit more plumbing to support. + dieWithException verbosity OnlySupportSpecificPackageDb -- | Call @hc-pkg@ to unregister a package -- -- > hc-pkg unregister [pkgid] [--user | --global | --package-db] --- -unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -unregister hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (unregisterInvocation hpi verbosity packagedb pkgid) - +unregister :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageId -> IO () +unregister hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to recache the registered packages. -- -- > hc-pkg recache [--user | --global | --package-db] --- -recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO () -recache hpi verbosity packagedb = - runProgramInvocation verbosity - (recacheInvocation hpi verbosity packagedb) - +recache :: HcPkgInfo -> Verbosity -> Maybe (SymbolicPath CWD (Dir from)) -> PackageDBS from -> IO () +recache hpi verbosity mbWorkDir packagedb = + runProgramInvocation + verbosity + (recacheInvocation hpi verbosity mbWorkDir packagedb) -- | Call @hc-pkg@ to expose a package. -- -- > hc-pkg expose [pkgid] [--user | --global | --package-db] --- -expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -expose hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (exposeInvocation hpi verbosity packagedb pkgid) +expose + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> IO () +expose hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (exposeInvocation hpi verbosity mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to retrieve a specific package -- -- > hc-pkg describe [pkgid] [--user | --global | --package-db] --- -describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo] -describe hpi verbosity packagedb pid = do - - output <- getProgramInvocationLBS verbosity - (describeInvocation hpi verbosity packagedb pid) - `catchIO` \_ -> return mempty +describe + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> PackageId + -> IO [InstalledPackageInfo] +describe hpi verbosity mbWorkDir packagedb pid = do + output <- + getProgramInvocationLBS + verbosity + (describeInvocation hpi verbosity mbWorkDir packagedb pid) + `catchIO` \_ -> return mempty case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'" + _ -> dieWithException verbosity $ FailedToParseOutputDescribe (programId (hcPkgProgram hpi)) pid -- | Call @hc-pkg@ to hide a package. -- -- > hc-pkg hide [pkgid] [--user | --global | --package-db] --- -hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO () -hide hpi verbosity packagedb pkgid = - runProgramInvocation verbosity - (hideInvocation hpi verbosity packagedb pkgid) - +hide + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> IO () +hide hpi verbosity mbWorkDir packagedb pkgid = + runProgramInvocation + verbosity + (hideInvocation hpi verbosity mbWorkDir packagedb pkgid) -- | Call @hc-pkg@ to get all the details of all the packages in the given -- package database. --- -dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo] -dump hpi verbosity packagedb = do - - output <- getProgramInvocationLBS verbosity - (dumpInvocation hpi verbosity packagedb) - `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: " - ++ displayException e +dump + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> IO [InstalledPackageInfo] +dump hpi verbosity mbWorkDir packagedb = do + output <- + getProgramInvocationLBS + verbosity + (dumpInvocation hpi verbosity mbWorkDir packagedb) + `catchIO` \e -> + dieWithException verbosity $ DumpFailed (programId (hcPkgProgram hpi)) (displayException e) case parsePackages output of Left ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " dump'" - + _ -> dieWithException verbosity $ FailedToParseOutputDump (programId (hcPkgProgram hpi)) parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String] parsePackages lbs0 = - case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of - Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ] - Left msgs -> Right (NE.toList msgs) + case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of + Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok] + Left msgs -> Right (NE.toList msgs) where splitPkgs :: LBS.ByteString -> [BS.ByteString] splitPkgs = checkEmpty . doSplit where -- Handle the case of there being no packages at all. checkEmpty [s] | BS.all isSpace8 s = [] - checkEmpty ss = ss + checkEmpty ss = ss isSpace8 :: Word8 -> Bool - isSpace8 9 = True -- '\t' + isSpace8 9 = True -- '\t' isSpace8 10 = True -- '\n' isSpace8 13 = True -- '\r' isSpace8 32 = True -- ' ' - isSpace8 _ = False + isSpace8 _ = False doSplit :: LBS.ByteString -> [BS.ByteString] doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs) where go :: [Int64] -> [BS.ByteString] - go [] = [ LBS.toStrict lbs ] - go (idx:idxs) = - let (pfx, sfx) = LBS.splitAt idx lbs - in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of + go [] = [LBS.toStrict lbs] + go (idx : idxs) = + let (pfx, sfx) = LBS.splitAt idx lbs + in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of Just sfx' -> LBS.toStrict pfx : doSplit sfx' - Nothing -> go idxs + Nothing -> go idxs separators :: [LBS.ByteString] separators = ["\n---\n", "\r\n---\r\n", "\r---\r"] @@ -303,25 +337,25 @@ | otherwise = Nothing #endif - mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec -- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) -- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. -- The "pkgroot" is the directory containing the package database. mungePackagePaths pkgroot pkginfo = - pkginfo { - importDirs = mungePaths (importDirs pkginfo), - includeDirs = mungePaths (includeDirs pkginfo), - libraryDirs = mungePaths (libraryDirs pkginfo), - libraryDynDirs = mungePaths (libraryDynDirs pkginfo), - frameworkDirs = mungePaths (frameworkDirs pkginfo), - haddockInterfaces = mungePaths (haddockInterfaces pkginfo), - haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + pkginfo + { importDirs = mungePaths (importDirs pkginfo) + , includeDirs = mungePaths (includeDirs pkginfo) + , libraryDirs = mungePaths (libraryDirs pkginfo) + , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo) + , libraryDynDirs = mungePaths (libraryDynDirs pkginfo) + , frameworkDirs = mungePaths (frameworkDirs pkginfo) + , haddockInterfaces = mungePaths (haddockInterfaces pkginfo) + , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) } where mungePaths = map mungePath - mungeUrls = map mungeUrl + mungeUrls = map mungeUrl mungePath p = case stripVarPrefix "${pkgroot}" p of Just p' -> pkgroot p' @@ -331,53 +365,56 @@ Just p' -> toUrlPath pkgroot p' Nothing -> p - toUrlPath r p = "file:///" - -- URLs always use posix style '/' separators: - ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + toUrlPath r p = + "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) stripVarPrefix var p = case splitPath p of - (root:path') -> case stripPrefix var root of + (root : path') -> case stripPrefix var root of Just [sep] | isPathSeparator sep -> Just (joinPath path') - _ -> Nothing - _ -> Nothing - + _ -> Nothing + _ -> Nothing -- Older installed package info files did not have the installedUnitId -- field, so if it is missing then we fill it as the source package ID. -- NB: Internal libraries not supported. setUnitId :: InstalledPackageInfo -> InstalledPackageInfo -setUnitId pkginfo@InstalledPackageInfo { - installedUnitId = uid, - sourcePackageId = pid - } | unUnitId uid == "" - = pkginfo { - installedUnitId = mkLegacyUnitId pid, - installedComponentId_ = mkComponentId (prettyShow pid) - } +setUnitId + pkginfo@InstalledPackageInfo + { installedUnitId = uid + , sourcePackageId = pid + } + | unUnitId uid == "" = + pkginfo + { installedUnitId = mkLegacyUnitId pid + , installedComponentId_ = mkComponentId (prettyShow pid) + } setUnitId pkginfo = pkginfo - -- | Call @hc-pkg@ to get the source package Id of all the packages in the -- given package database. -- -- This is much less information than with 'dump', but also rather quicker. -- Note in particular that it does not include the 'UnitId', just -- the source 'PackageId' which is not necessarily unique in any package db. --- -list :: HcPkgInfo -> Verbosity -> PackageDB - -> IO [PackageId] -list hpi verbosity packagedb = do - - output <- getProgramInvocationOutput verbosity - (listInvocation hpi verbosity packagedb) - `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed" +list + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> IO [PackageId] +list hpi verbosity mbWorkDir packagedb = do + output <- + getProgramInvocationOutput + verbosity + (listInvocation hpi verbosity mbWorkDir packagedb) + `catchIO` \_ -> dieWithException verbosity $ ListFailed (programId (hcPkgProgram hpi)) case parsePackageIds output of Just ok -> return ok - _ -> die' verbosity $ "failed to parse output of '" - ++ programId (hcPkgProgram hpi) ++ " list'" - + _ -> dieWithException verbosity $ FailedToParseOutputList (programId (hcPkgProgram hpi)) where parsePackageIds = traverse simpleParsec . words @@ -387,130 +424,173 @@ initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation initInvocation hpi verbosity path = - programInvocation (hcPkgProgram hpi) args + programInvocation (hcPkgProgram hpi) args where - args = ["init", path] + args = + ["init", path] ++ verbosityOpts hpi verbosity registerInvocation - :: HcPkgInfo -> Verbosity -> PackageDBStack + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from -> InstalledPackageInfo -> RegisterOptions -> ProgramInvocation -registerInvocation hpi verbosity packagedbs pkgInfo registerOptions = - (programInvocation (hcPkgProgram hpi) (args "-")) { - progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo, - progInvokeInputEncoding = IOEncodingUTF8 +registerInvocation hpi verbosity mbWorkDir packagedbs pkgInfo registerOptions = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) (args "-")) + { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo + , progInvokeInputEncoding = IOEncodingUTF8 } where cmdname | registerAllowOverwrite registerOptions = "update" - | registerMultiInstance registerOptions = "update" - | otherwise = "register" - - args file = [cmdname, file] - ++ packageDbStackOpts hpi packagedbs - ++ [ "--enable-multi-instance" - | registerMultiInstance registerOptions ] - ++ [ "--force-files" - | registerSuppressFilesCheck registerOptions ] - ++ verbosityOpts hpi verbosity - -unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -unregisterInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity - + | registerMultiInstance registerOptions = "update" + | otherwise = "register" -recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB - -> ProgramInvocation -recacheInvocation hpi verbosity packagedb = - programInvocation (hcPkgProgram hpi) $ - ["recache", packageDbOpts hpi packagedb] - ++ verbosityOpts hpi verbosity + args file = + [cmdname, file] + ++ packageDbStackOpts hpi packagedbs + ++ [ "--enable-multi-instance" + | registerMultiInstance registerOptions + ] + ++ [ "--force-files" + | registerSuppressFilesCheck registerOptions + ] + ++ verbosityOpts hpi verbosity +unregisterInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +unregisterInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity -exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -exposeInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity +recacheInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBS from + -> ProgramInvocation +recacheInvocation hpi verbosity mbWorkDir packagedb = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["recache", packageDbOpts hpi packagedb] + ++ verbosityOpts hpi verbosity -describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId - -> ProgramInvocation -describeInvocation hpi verbosity packagedbs pkgid = - programInvocation (hcPkgProgram hpi) $ - ["describe", prettyShow pkgid] - ++ packageDbStackOpts hpi packagedbs - ++ verbosityOpts hpi verbosity +exposeInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +exposeInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["expose", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity -hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -hideInvocation hpi verbosity packagedb pkgid = - programInvocation (hcPkgProgram hpi) $ - ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] - ++ verbosityOpts hpi verbosity +describeInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> PackageId + -> ProgramInvocation +describeInvocation hpi verbosity mbWorkDir packagedbs pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["describe", prettyShow pkgid] + ++ packageDbStackOpts hpi packagedbs + ++ verbosityOpts hpi verbosity +hideInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> PackageId + -> ProgramInvocation +hideInvocation hpi verbosity mbWorkDir packagedb pkgid = + programInvocationCwd mbWorkDir (hcPkgProgram hpi) $ + ["hide", packageDbOpts hpi packagedb, prettyShow pkgid] + ++ verbosityOpts hpi verbosity -dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation -dumpInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 +dumpInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> ProgramInvocation +dumpInvocation hpi _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["dump", packageDbOpts hpi packagedb] + args = + ["dump", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. -listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation -listInvocation hpi _verbosity packagedb = - (programInvocation (hcPkgProgram hpi) args) { - progInvokeOutputEncoding = IOEncodingUTF8 +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. + +listInvocation + :: HcPkgInfo + -> Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDB + -> ProgramInvocation +listInvocation hpi _verbosity mbWorkDir packagedb = + (programInvocationCwd mbWorkDir (hcPkgProgram hpi) args) + { progInvokeOutputEncoding = IOEncodingUTF8 } where - args = ["list", "--simple-output", packageDbOpts hpi packagedb] + args = + ["list", "--simple-output", packageDbOpts hpi packagedb] ++ verbosityOpts hpi silent - -- We use verbosity level 'silent' because it is important that we - -- do not contaminate the output with info/debug messages. +-- We use verbosity level 'silent' because it is important that we +-- do not contaminate the output with info/debug messages. -packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String] +packageDbStackOpts :: HcPkgInfo -> PackageDBStackS from -> [String] packageDbStackOpts hpi dbstack | noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)] - | otherwise = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : ("--no-user-" ++ packageDbFlag hpi) - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + | otherwise = case dbstack of + (GlobalPackageDB : UserPackageDB : dbs) -> + "--global" + : "--user" + : map specific dbs + (GlobalPackageDB : dbs) -> + "--global" + : ("--no-user-" ++ packageDbFlag hpi) + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) packageDbFlag :: HcPkgInfo -> String packageDbFlag hpi - | flagPackageConf hpi - = "package-conf" - | otherwise - = "package-db" + | flagPackageConf hpi = + "package-conf" + | otherwise = + "package-db" -packageDbOpts :: HcPkgInfo -> PackageDB -> String -packageDbOpts _ GlobalPackageDB = "--global" -packageDbOpts _ UserPackageDB = "--user" -packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db +packageDbOpts :: HcPkgInfo -> PackageDBX (SymbolicPath from (Dir PkgDB)) -> String +packageDbOpts _ GlobalPackageDB = "--global" +packageDbOpts _ UserPackageDB = "--user" +packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ interpretSymbolicPathCWD db verbosityOpts :: HcPkgInfo -> Verbosity -> [String] verbosityOpts hpi v - | noVerboseFlag hpi - = [] + | noVerboseFlag hpi = + [] | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] + | v == silent = ["-v0"] + | otherwise = [] diff --git a/src/Distribution/Simple/Program/Hpc.hs b/src/Distribution/Simple/Program/Hpc.hs --- a/src/Distribution/Simple/Program/Hpc.hs +++ b/src/Distribution/Simple/Program/Hpc.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Hpc -- Copyright : Thomas Tuegel 2011 @@ -10,22 +12,20 @@ -- Portability : portable -- -- This module provides an library interface to the @hpc@ program. - module Distribution.Simple.Program.Hpc - ( markup - , union - ) where + ( markup + , union + ) where -import Prelude () import Distribution.Compat.Prelude - -import System.Directory (makeRelativeToCurrentDirectory) +import Prelude () import Distribution.ModuleName +import Distribution.Pretty import Distribution.Simple.Program.Run import Distribution.Simple.Program.Types -import Distribution.Pretty import Distribution.Simple.Utils +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version @@ -36,74 +36,107 @@ -- first path in the list. This means that e.g. test suites that import their -- library as a dependency can still work, but those that include the library -- modules directly (in other-modules) don't. -markup :: ConfiguredProgram - -> Version - -> Verbosity - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be located - -> [ModuleName] -- ^ List of modules to include in the report - -> IO () -markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do - hpcDirs' <- if withinRange hpcVer (orLaterVersion version07) - then return hpcDirs - else do - warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer - ++ ") does not properly handle multiple search paths. " - ++ "Coverage report generation may fail unexpectedly. These " - ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " - ++ "later)." - ++ if null droppedDirs - then "" - else " The following search paths have been abandoned: " - ++ show droppedDirs - return passedDirs +markup + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> Version + -> Verbosity + -> SymbolicPath Pkg File + -- ^ Path to .tix file + -> [SymbolicPath Pkg (Dir Mix)] + -- ^ Paths to .mix file directories + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path where html output should be located + -> [ModuleName] + -- ^ List of modules to include in the report + -> IO () +markup mbWorkDir hpc hpcVer verbosity tixFile hpcDirs destDir included = do + hpcDirs' <- + if withinRange hpcVer (orLaterVersion version07) + then return hpcDirs + else do + warn verbosity $ + "Your version of HPC (" + ++ prettyShow hpcVer + ++ ") does not properly handle multiple search paths. " + ++ "Coverage report generation may fail unexpectedly. These " + ++ "issues are addressed in version 0.7 or later (GHC 7.8 or " + ++ "later)." + ++ if null droppedDirs + then "" + else + " The following search paths have been abandoned: " + ++ show droppedDirs + return passedDirs - -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. - hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs' + -- Prior to GHC 8.0, hpc assumes all .mix paths are relative. + hpcDirs'' <- traverse (tryMakeRelative mbWorkDir) hpcDirs' - runProgramInvocation verbosity - (markupInvocation hpc tixFile hpcDirs'' destDir included) + runProgramInvocation + verbosity + (markupInvocation mbWorkDir hpc tixFile hpcDirs'' destDir included) where version07 = mkVersion [0, 7] (passedDirs, droppedDirs) = splitAt 1 hpcDirs -markupInvocation :: ConfiguredProgram - -> FilePath -- ^ Path to .tix file - -> [FilePath] -- ^ Paths to .mix file directories - -> FilePath -- ^ Path where html output should be - -- located - -> [ModuleName] -- ^ List of modules to include - -> ProgramInvocation -markupInvocation hpc tixFile hpcDirs destDir included = - let args = [ "markup", tixFile - , "--destdir=" ++ destDir - ] - ++ map ("--hpcdir=" ++) hpcDirs - ++ ["--include=" ++ prettyShow moduleName - | moduleName <- included ] - in programInvocation hpc args +markupInvocation + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> SymbolicPath Pkg File + -- ^ Path to .tix file + -> [SymbolicPath Pkg (Dir Mix)] + -- ^ Paths to .mix file directories + -> SymbolicPath Pkg (Dir Artifacts) + -- ^ Path where html output should be + -- located + -> [ModuleName] + -- ^ List of modules to include + -> ProgramInvocation +markupInvocation mbWorkDir hpc tixFile hpcDirs destDir included = + let args = + [ "markup" + , getSymbolicPath tixFile + , "--destdir=" ++ getSymbolicPath destDir + ] + ++ map (("--hpcdir=" ++) . getSymbolicPath) hpcDirs + ++ [ "--include=" ++ prettyShow moduleName + | moduleName <- included + ] + in programInvocationCwd mbWorkDir hpc args -union :: ConfiguredProgram - -> Verbosity - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> IO () -union hpc verbosity tixFiles outFile excluded = - runProgramInvocation verbosity - (unionInvocation hpc tixFiles outFile excluded) +union + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> Verbosity + -> [SymbolicPath Pkg File] + -- ^ Paths to .tix files + -> SymbolicPath Pkg File + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> IO () +union mbWorkDir hpc verbosity tixFiles outFile excluded = + runProgramInvocation + verbosity + (unionInvocation mbWorkDir hpc tixFiles outFile excluded) -unionInvocation :: ConfiguredProgram - -> [FilePath] -- ^ Paths to .tix files - -> FilePath -- ^ Path to resultant .tix file - -> [ModuleName] -- ^ List of modules to exclude from union - -> ProgramInvocation -unionInvocation hpc tixFiles outFile excluded = - programInvocation hpc $ concat - [ ["sum", "--union"] - , tixFiles - , ["--output=" ++ outFile] - , ["--exclude=" ++ prettyShow moduleName - | moduleName <- excluded ] +unionInvocation + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -> ConfiguredProgram + -> [SymbolicPath Pkg File] + -- ^ Paths to .tix files + -> SymbolicPath Pkg File + -- ^ Path to resultant .tix file + -> [ModuleName] + -- ^ List of modules to exclude from union + -> ProgramInvocation +unionInvocation mbWorkDir hpc tixFiles outFile excluded = + programInvocationCwd mbWorkDir hpc $ + concat + [ ["sum", "--union"] + , map getSymbolicPath tixFiles + , ["--output=" ++ getSymbolicPath outFile] + , [ "--exclude=" ++ prettyShow moduleName + | moduleName <- excluded ] + ] diff --git a/src/Distribution/Simple/Program/Internal.hs b/src/Distribution/Simple/Program/Internal.hs --- a/src/Distribution/Simple/Program/Internal.hs +++ b/src/Distribution/Simple/Program/Internal.hs @@ -1,4 +1,5 @@ ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Internal -- @@ -6,42 +7,47 @@ -- Portability : portable -- -- Internal utilities used by Distribution.Simple.Program.*. - -module Distribution.Simple.Program.Internal ( - stripExtractVersion, +module Distribution.Simple.Program.Internal + ( stripExtractVersion ) where -import Prelude () import Distribution.Compat.Prelude -import Distribution.Utils.Generic(safeTail) +import Distribution.Utils.Generic (safeTail) +import Prelude () -- | Extract the version number from the output of 'strip --version'. -- --- Invoking "strip --version" gives very inconsistent results. We ignore --- everything in parentheses (see #2497), look for the first word that starts --- with a number, and try parsing out the first two components of it. Non-GNU --- 'strip' doesn't appear to have a version flag. +-- Invoking "strip --version" gives very inconsistent results. We +-- ignore everything in parentheses (see #2497), look for the first +-- word that starts with a number, and try parsing out the first two +-- components of it. Non-GNU, non-LLVM 'strip' doesn't appear to have +-- a version flag. stripExtractVersion :: String -> String stripExtractVersion str = - let numeric "" = False - numeric (x:_) = isDigit x + let numeric "" = False + numeric (x : _) = isDigit x + closingParentheses = + [ ")" + , -- LLVM strip outputs "llvm-strip, compatible with GNU strip\nLLVM (http://llvm.org/):\n..." + "):" + ] + -- Filter out everything in parentheses. filterPar' :: Int -> [String] -> [String] - filterPar' _ [] = [] - filterPar' n (x:xs) - | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs) - | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs - | n > 0 = filterPar' n xs - | otherwise = x:filterPar' n xs + filterPar' _ [] = [] + filterPar' n (x : xs) + | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs) + | n > 0 && any (`isSuffixOf` x) closingParentheses = filterPar' (n - 1) xs + | n > 0 = filterPar' n xs + | otherwise = x : filterPar' n xs filterPar = filterPar' 0 - - in case dropWhile (not . numeric) (filterPar . words $ str) of - (ver:_) -> - -- take the first two version components - let isDot = (== '.') - (major, rest) = break isDot ver - minor = takeWhile isDigit (dropWhile isDot rest) - in major ++ "." ++ minor - _ -> "" + in case dropWhile (not . numeric) (filterPar . words $ str) of + (ver : _) -> + -- take the first two version components + let isDot = (== '.') + (major, rest) = break isDot ver + minor = takeWhile isDigit (dropWhile isDot rest) + in major ++ "." ++ minor + _ -> "" diff --git a/src/Distribution/Simple/Program/Ld.hs b/src/Distribution/Simple/Program/Ld.hs --- a/src/Distribution/Simple/Program/Ld.hs +++ b/src/Distribution/Simple/Program/Ld.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Ld -- Copyright : Duncan Coutts 2009 @@ -10,83 +12,99 @@ -- Portability : portable -- -- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, +module Distribution.Simple.Program.Ld + ( combineObjectFiles ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Compiler (arResponseFilesSupported) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) +import Distribution.Simple.Flag + ( fromFlagOrDefault + ) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI) import Distribution.Simple.Program.ResponseFile - ( withResponseFile ) + ( withResponseFile + ) import Distribution.Simple.Program.Run - ( ProgramInvocation, programInvocation, multiStageProgramInvocation - , runProgramInvocation ) + ( ProgramInvocation + , multiStageProgramInvocation + , programInvocationCwd + , runProgramInvocation + ) import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Setup - ( fromFlagOrDefault, configUseResponseFiles ) + ( ConfiguredProgram (..) + ) +import Distribution.Simple.Setup.Config + ( configUseResponseFiles + ) import Distribution.Simple.Utils - ( defaultTempFileOptions ) + ( defaultTempFileOptions + ) +import Distribution.Utils.Path import Distribution.Verbosity - ( Verbosity ) + ( Verbosity + ) import System.Directory - ( renameFile ) -import System.FilePath - ( (<.>), takeDirectory ) + ( renameFile + ) -- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -combineObjectFiles verbosity lbi ld target files = do - +combineObjectFiles + :: Verbosity + -> LocalBuildInfo + -> ConfiguredProgram + -> SymbolicPath Pkg File + -> [SymbolicPath Pkg File] + -> IO () +combineObjectFiles verbosity lbi ldProg target files = do -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, -- if we have more object files than fit on a single command line then we -- have a slight problem. What we have to do is link files in batches into -- a temp object file and then include that one in the next batch. - let simpleArgs = ["-r", "-o", target] + let + -- See Note [Symbolic paths] in Distribution.Utils.Path + u :: SymbolicPath Pkg to -> FilePath + u = interpretSymbolicPathCWD + i = interpretSymbolicPath mbWorkDir + mbWorkDir = mbWorkDirLBI lbi - initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs + simpleArgs = ["-r", "-o", u target] + initialArgs = ["-r", "-o", u target] + middleArgs = ["-r", "-o", u target, u tmpfile] + finalArgs = middleArgs - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs + ld = programInvocationCwd (mbWorkDirLBI lbi) ldProg + simple = ld simpleArgs + initial = ld initialArgs + middle = ld middleArgs + final = ld finalArgs - targetDir = takeDirectory target + invokeWithResponseFile :: FilePath -> ProgramInvocation + invokeWithResponseFile atFile = + ld $ simpleArgs ++ ['@' : atFile] - invokeWithResponesFile :: FilePath -> ProgramInvocation - invokeWithResponesFile atFile = - programInvocation ld $ simpleArgs ++ ['@' : atFile] + oldVersionManualOverride = + fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi + -- Whether ghc's ar supports response files is a good proxy for + -- whether ghc's ld supports them as well. + responseArgumentsNotSupported = + not (arResponseFilesSupported (compiler lbi)) - oldVersionManualOverride = - fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi - -- Whether ghc's ar supports response files is a good proxy for - -- whether ghc's ld supports them as well. - responseArgumentsNotSupported = - not (arResponseFilesSupported (compiler lbi)) + run :: [ProgramInvocation] -> IO () + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv : invs) = do + runProgramInvocation verbosity inv + renameFile (i target) (i tmpfile) + run invs if oldVersionManualOverride || responseArgumentsNotSupported - then - run $ multiStageProgramInvocation simple (initial, middle, final) files - else - withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $ - \path -> runProgramInvocation verbosity $ invokeWithResponesFile path - + then run $ multiStageProgramInvocation simple (initial, middle, final) (map getSymbolicPath files) + else withResponseFile verbosity defaultTempFileOptions "ld.rsp" Nothing (map getSymbolicPath files) $ + \path -> runProgramInvocation verbosity $ invokeWithResponseFile path where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - - run :: [ProgramInvocation] -> IO () - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file diff --git a/src/Distribution/Simple/Program/ResponseFile.hs b/src/Distribution/Simple/Program/ResponseFile.hs --- a/src/Distribution/Simple/Program/ResponseFile.hs +++ b/src/Distribution/Simple/Program/ResponseFile.hs @@ -1,6 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} + ---------------------------------------------------------------------------- + +---------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.ResponseFile -- Copyright : (c) Sergey Vinokurov 2017 @@ -8,30 +13,35 @@ -- -- Maintainer : cabal-devel@haskell.org -- Created : 23 July 2017 ----------------------------------------------------------------------------- - module Distribution.Simple.Program.ResponseFile (withResponseFile) where +import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding) import Prelude () -import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose) import Distribution.Compat.Prelude -import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug) +import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx) +import Distribution.Utils.Path import Distribution.Verbosity withResponseFile :: Verbosity -> TempFileOptions - -> FilePath -- ^ Working directory to create response file in. - -> FilePath -- ^ Template for response file name. - -> Maybe TextEncoding -- ^ Encoding to use for response file contents. - -> [String] -- ^ Arguments to put into response file. + -> String + -- ^ Template for response file name. + -> Maybe TextEncoding + -- ^ Encoding to use for response file contents. + -> [String] + -- ^ Arguments to put into response file. -> (FilePath -> IO a) -> IO a -withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f = - withTempFileEx tmpFileOpts workDir fileNameTemplate $ \responseFileName hf -> do +withResponseFile verbosity tmpFileOpts fileNameTemplate encoding arguments f = + withTempFileEx tmpFileOpts fileNameTemplate $ \responsePath hf -> do + let responseFileName = getSymbolicPath responsePath traverse_ (hSetEncoding hf) encoding - let responseContents = unlines $ map escapeResponseFileArg arguments + let responseContents = + unlines $ + map escapeResponseFileArg $ + arguments hPutStr hf responseContents hClose hf debug verbosity $ responseFileName ++ " contents: <<<" @@ -51,10 +61,9 @@ escape :: String -> Char -> String escape cs c = case c of - '\\' -> c:'\\':cs - '\'' -> c:'\\':cs - '"' -> c:'\\':cs - _ | isSpace c -> c:'\\':cs - | otherwise -> c:cs - - + '\\' -> c : '\\' : cs + '\'' -> c : '\\' : cs + '"' -> c : '\\' : cs + _ + | isSpace c -> c : '\\' : cs + | otherwise -> c : cs diff --git a/src/Distribution/Simple/Program/Run.hs b/src/Distribution/Simple/Program/Run.hs --- a/src/Distribution/Simple/Program/Run.hs +++ b/src/Distribution/Simple/Program/Run.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Run -- Copyright : Duncan Coutts 2009 @@ -12,36 +15,36 @@ -- -- This module provides a data type for program invocations and functions to -- run them. - -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - getProgramInvocationLBS, - getProgramInvocationOutputAndErrors, - - getEffectiveEnvironment, +module Distribution.Simple.Program.Run + ( ProgramInvocation (..) + , IOEncoding (..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , programInvocationCwd + , multiStageProgramInvocation + , runProgramInvocation + , getProgramInvocationOutput + , getProgramInvocationLBS + , getProgramInvocationOutputAndErrors + , getProgramInvocationLBSAndErrors + , getEffectiveEnvironment + , getFullEnvironment ) where import Distribution.Compat.Prelude import Prelude () import Distribution.Compat.Environment +import Distribution.Simple.Errors import Distribution.Simple.Program.Types import Distribution.Simple.Utils import Distribution.Utils.Generic +import Distribution.Utils.Path import Distribution.Verbosity -import System.FilePath (searchPathSeparator) - import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as Map +import qualified Data.Map as Map -- | Represents a specific invocation of a specific program. -- @@ -49,180 +52,220 @@ -- and actually doing it. This provides the opportunity to the caller to -- adjust how the program will be called. These invocations can either be run -- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, Maybe String)], - -- Extra paths to add to PATH - progInvokePathEnv :: [FilePath], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe IOData, - progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. - progInvokeOutputEncoding :: IOEncoding - } +data ProgramInvocation = ProgramInvocation + { progInvokePath :: FilePath + , progInvokeArgs :: [String] + , progInvokeEnv :: [(String, Maybe String)] + , progInvokeCwd :: Maybe FilePath + , progInvokeInput :: Maybe IOData + , progInvokeInputEncoding :: IOEncoding + -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. + , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool + } -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 +data IOEncoding + = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 encodeToIOData :: IOEncoding -> IOData -> IOData -encodeToIOData _ iod@(IODataBinary _) = iod -encodeToIOData IOEncodingText iod@(IODataText _) = iod -encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) +encodeToIOData _ iod@(IODataBinary _) = iod +encodeToIOData IOEncodingText iod@(IODataText _) = iod +encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str) emptyProgramInvocation :: ProgramInvocation emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } + ProgramInvocation + { progInvokePath = "" + , progInvokeArgs = [] + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + , progInvokeInputEncoding = IOEncodingText + , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True + } -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation + :: FilePath + -> [String] + -> ProgramInvocation simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } + emptyProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + } -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation + :: ConfiguredProgram + -> [String] + -> ProgramInvocation programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog, - progInvokeEnv = programOverrideEnv prog - } + emptyProgramInvocation + { progInvokePath = programPath prog + , progInvokeArgs = + programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + , progInvokeEnv = programOverrideEnv prog + } +programInvocationCwd + :: forall to + . Maybe (SymbolicPath CWD (Dir to)) + -> ConfiguredProgram + -> [String] + -> ProgramInvocation +programInvocationCwd mbWorkDir prog args = + (programInvocation prog args) + { progInvokeCwd = fmap getSymbolicPath mbWorkDir + } runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokePathEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Nothing - } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - exitCode <- rawSystemIOWithEnv verbosity - path args - mcwd menv - Nothing Nothing Nothing - when (exitCode /= ExitSuccess) $ - exitWith exitCode - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envOverrides, - progInvokePathEnv = extraPath, - progInvokeCwd = mcwd, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - mcwd menv - (Just input) IODataModeBinary +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = [] + , progInvokeCwd = Nothing + , progInvokeInput = Nothing + } = + rawSystemExit verbosity Nothing path args +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Nothing + } = do + menv <- getEffectiveEnvironment envOverrides + maybeExit $ + rawSystemIOWithEnv + verbosity + path + args + mcwd + menv + Nothing + Nothing + Nothing +runProgramInvocation + verbosity + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = Just inputStr + , progInvokeInputEncoding = encoding + } = do + menv <- getEffectiveEnvironment envOverrides + (_, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + mcwd + menv + (Just input) + IODataModeBinary when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors - where - input = encodeToIOData encoding inputStr + dieWithException verbosity $ + RunProgramInvocationException path errors + where + input = encodeToIOData encoding inputStr getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String getProgramInvocationOutput verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output + (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv + when (exitCode /= ExitSuccess) $ + die' verbosity $ + "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors + return output getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString getProgramInvocationLBS verbosity inv = do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - when (exitCode /= ExitSuccess) $ - die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors - return output + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + GetProgramInvocationLBSException (progInvokePath inv) errors + return output -getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation - -> IO (String, String, ExitCode) +getProgramInvocationOutputAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (String, String, ExitCode) getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of - IOEncodingText -> do - (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText - return (output, errors, exitCode) - IOEncodingUTF8 -> do - (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary - return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) + IOEncodingText -> do + (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText + return (output, errors, exitCode) + IOEncodingUTF8 -> do + (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode) +getProgramInvocationLBSAndErrors + :: Verbosity + -> ProgramInvocation + -> IO (LBS.ByteString, String, ExitCode) +getProgramInvocationLBSAndErrors verbosity inv = + getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary + getProgramInvocationIODataAndErrors - :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode - -> IO (mode, String, ExitCode) + :: KnownIODataMode mode + => Verbosity + -> ProgramInvocation + -> IODataMode mode + -> IO (mode, String, ExitCode) getProgramInvocationIODataAndErrors verbosity ProgramInvocation - { progInvokePath = path - , progInvokeArgs = args - , progInvokeEnv = envOverrides - , progInvokePathEnv = extraPath - , progInvokeCwd = mcwd - , progInvokeInput = minputStr + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envOverrides + , progInvokeCwd = mcwd + , progInvokeInput = minputStr , progInvokeInputEncoding = encoding } mode = do - pathOverride <- getExtraPathEnv envOverrides extraPath - menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) + menv <- getEffectiveEnvironment envOverrides rawSystemStdInOut verbosity path args mcwd menv input mode - where - input = encodeToIOData encoding <$> minputStr - -getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)] -getExtraPathEnv _ [] = return [] -getExtraPathEnv env extras = do - mb_path <- case lookup "PATH" env of - Just x -> return x - Nothing -> lookupEnv "PATH" - let extra = intercalate [searchPathSeparator] extras - path' = case mb_path of - Nothing -> extra - Just path -> extra ++ searchPathSeparator : path - return [("PATH", Just path')] + where + input = encodeToIOData encoding <$> minputStr -- | Return the current environment extended with the given overrides. -- If an entry is specified twice in @overrides@, the second entry takes -- precedence. -- -getEffectiveEnvironment :: [(String, Maybe String)] - -> IO (Maybe [(String, String)]) -getEffectiveEnvironment [] = return Nothing +-- getEffectiveEnvironment returns 'Nothing' when there are no overrides. +-- It returns an argument that is suitable to pass directly to 'CreateProcess' to +-- override the environment. +-- If you need the full environment to manipulate further, even when there are no overrides, +-- then call 'getFullEnvironment'. +getEffectiveEnvironment + :: [(String, Maybe String)] + -> IO (Maybe [(String, String)]) +getEffectiveEnvironment [] = return Nothing getEffectiveEnvironment overrides = - fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment + fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment where apply os env = foldl' (flip update) env os - update (var, Nothing) = Map.delete var + update (var, Nothing) = Map.delete var update (var, Just val) = Map.insert var val +-- | Like 'getEffectiveEnvironment', but when no overrides are specified, +-- returns the full environment instead of 'Nothing'. +getFullEnvironment + :: [(String, Maybe String)] + -> IO [(String, String)] +getFullEnvironment overrides = do + menv <- getEffectiveEnvironment overrides + case menv of + Just env -> return env + Nothing -> getEnvironment + -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you -- need to invoke a command multiple times to get all the args in. @@ -242,53 +285,51 @@ -- > $ middle args_2 -- > ... -- > $ final args_n --- multiStageProgramInvocation :: ProgramInvocation -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) -> [String] -> [ProgramInvocation] multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + let argSize inv = + length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - + chunkSize = maxCommandLineSize - fixedArgSize in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) -> - [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- xs ] - ++ [ final `appendArgs` x ] - + [] -> [simple] + [c] -> [simple `appendArgs` c] + (c : c2 : cs) + | (xs, x) <- unsnocNE (c2 :| cs) -> + [initial `appendArgs` c] + ++ [middle `appendArgs` c' | c' <- xs] + ++ [final `appendArgs` x] where appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as} splitChunks :: Int -> [[a]] -> [[[a]]] splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) + if null s + then Nothing + else Just (chunk len s) chunk :: Int -> [[a]] -> ([[a]], [[a]]) - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss + chunk len (s : _) | length s >= len = error toolong + chunk len ss = chunk' [] len ss chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - where len' = length s - chunk' acc _ ss = (reverse acc, ss) - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" + chunk' acc len (s : ss) + | len' < len = chunk' (s : acc) (len - len' - 1) ss + where + len' = length s + chunk' acc _ ss = (reverse acc, ss) + toolong = + "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" ---FIXME: discover this at configure time or runtime on unix +-- FIXME: discover this at configure time or runtime on unix -- The value is 32k on Windows and posix specifies a minimum of 4k -- but all sensible unixes use more than 4k. -- we could use getSysVar ArgumentLimit but that's in the unix lib diff --git a/src/Distribution/Simple/Program/Script.hs b/src/Distribution/Simple/Program/Script.hs --- a/src/Distribution/Simple/Program/Script.hs +++ b/src/Distribution/Simple/Program/Script.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Script -- Copyright : Duncan Coutts 2009 @@ -9,16 +11,14 @@ -- -- This module provides an library interface to the @hc-pkg@ program. -- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, +module Distribution.Simple.Program.Script + ( invocationAsSystemScript + , invocationAsShellScript + , invocationAsBatchFile ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program.Run import Distribution.Simple.Utils @@ -26,89 +26,89 @@ -- | Generate a system script, either POSIX shell script or Windows batch file -- as appropriate for the given system. --- invocationAsSystemScript :: OS -> ProgramInvocation -> String invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - +invocationAsSystemScript _ = invocationAsShellScript -- | Generate a POSIX shell script that invokes a program. --- invocationAsShellScript :: ProgramInvocation -> String invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ concatMap setEnv envExtra - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "echo " ++ quote (iodataToText input) ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] - setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["#!/bin/sh"] + ++ concatMap setEnv envExtra + ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd] + ++ [ ( case minput of + Nothing -> "" + Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | " + ) + ++ unwords (map quote $ path : args) + ++ " \"$@\"" + ] + where + setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var] + setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val] - quote :: String -> String - quote s = "'" ++ escape s ++ "'" + quote :: String -> String + quote s = "'" ++ escape s ++ "'" - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs + escape [] = [] + escape ('\'' : cs) = "'\\''" ++ escape cs + escape (c : cs) = c : escape cs iodataToText :: IOData -> String -iodataToText (IODataText str) = str +iodataToText (IODataText str) = str iodataToText (IODataBinary lbs) = fromUTF8LBS lbs - -- | Generate a Windows batch file that invokes a program. --- invocationAsBatchFile :: ProgramInvocation -> String invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ map setEnv envExtra - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - setEnv (var, Nothing) = "set " ++ var ++ "=" - setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val + ProgramInvocation + { progInvokePath = path + , progInvokeArgs = args + , progInvokeEnv = envExtra + , progInvokeCwd = mcwd + , progInvokeInput = minput + } = + unlines $ + ["@echo off"] + ++ map setEnv envExtra + ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd] + ++ case minput of + Nothing -> + [path ++ concatMap (' ' :) args] + Just input -> + ["("] + ++ ["echo " ++ escape line | line <- lines $ iodataToText input] + ++ [ ") | " + ++ "\"" + ++ path + ++ "\"" + ++ concatMap (\arg -> ' ' : quote arg) args + ] + where + setEnv (var, Nothing) = "set " ++ var ++ "=" + setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs + escapeQ [] = [] + escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c : cs) = c : escapeQ cs - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs + escape [] = [] + escape ('|' : cs) = "^|" ++ escape cs + escape ('<' : cs) = "^<" ++ escape cs + escape ('>' : cs) = "^>" ++ escape cs + escape ('&' : cs) = "^&" ++ escape cs + escape ('(' : cs) = "^(" ++ escape cs + escape (')' : cs) = "^)" ++ escape cs + escape ('^' : cs) = "^^" ++ escape cs + escape (c : cs) = c : escape cs diff --git a/src/Distribution/Simple/Program/Strip.hs b/src/Distribution/Simple/Program/Strip.hs --- a/src/Distribution/Simple/Program/Strip.hs +++ b/src/Distribution/Simple/Program/Strip.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Strip -- @@ -9,12 +10,11 @@ -- Portability : portable -- -- This module provides an library interface to the @strip@ program. - module Distribution.Simple.Program.Strip (stripLib, stripExe) - where +where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Simple.Program import Distribution.Simple.Utils @@ -22,54 +22,66 @@ import Distribution.Verbosity import Distribution.Version -import System.FilePath (takeBaseName) +import System.FilePath (takeBaseName) runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO () runStrip verbosity progDb path args = case lookupProgram stripProgram progDb of Just strip -> runProgram verbosity strip (args ++ [path]) - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable or library '" - ++ (takeBaseName path) - ++ "' (missing the 'strip' program)" + Nothing -> + unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ + "Unable to strip executable or library '" + ++ (takeBaseName path) + ++ "' (missing the 'strip' program)" stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripExe verbosity (Platform _arch os) progdb path = runStrip verbosity progdb path args where args = case os of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO () stripLib verbosity (Platform arch os) progdb path = do case os of - OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or - -- Solaris. See #1630. - return () + OSX -> + -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or + -- Solaris. See #1630. + return () IOS -> return () AIX -> return () Solaris -> return () - Windows -> -- Stripping triggers a bug in 'strip.exe' for - -- libraries with lots identically named modules. See - -- #1784. - return() - Linux | arch == I386 -> - -- Versions of 'strip' on 32-bit Linux older than 2.18 are - -- broken. See #2339. - let okVersion = orLaterVersion (mkVersion [2,18]) - in case programVersion =<< lookupProgram stripProgram progdb of - Just v | withinRange v okVersion -> - runStrip verbosity progdb path args - _ -> warn verbosity $ "Unable to strip library '" - ++ (takeBaseName path) - ++ "' (version of 'strip' too old; " - ++ "requires >= 2.18 on 32-bit Linux)" - _ -> runStrip verbosity progdb path args + OpenBSD -> + -- '--strip-unneeded' sometimes strips too much on OpenBSD. + -- -- See https://cvsweb.openbsd.org/cgi-bin/cvsweb/~checkout~/ports/lang/ghc/patches/patch-libraries_Cabal_Cabal_Distribution_Simple_Program_Strip_hs + return () + Windows -> + -- Stripping triggers a bug in 'strip.exe' for + -- libraries with lots identically named modules. See + -- #1784. + return () + Linux + | arch == I386 -> + -- Versions of 'strip' on 32-bit Linux older than 2.18 are + -- broken. See #2339. + let okVersion = orLaterVersion (mkVersion [2, 18]) + in case programVersion =<< lookupProgram stripProgram progdb of + Just v + | withinRange v okVersion -> + runStrip verbosity progdb path args + _ -> + warn verbosity $ + "Unable to strip library '" + ++ (takeBaseName path) + ++ "' (version of 'strip' too old; " + ++ "requires >= 2.18 on 32-bit Linux)" + _ -> runStrip verbosity progdb path args where args = ["--strip-unneeded"] diff --git a/src/Distribution/Simple/Program/Types.hs b/src/Distribution/Simple/Program/Types.hs --- a/src/Distribution/Simple/Program/Types.hs +++ b/src/Distribution/Simple/Program/Types.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Program.Types -- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 @@ -19,30 +18,27 @@ -- args). Configuring a program involves finding its location and if necessary -- finding its version. There's reasonable default behavior for trying to find -- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - ProgramSearchPath, - ProgramSearchPathEntry(..), - simpleProgram, +module Distribution.Simple.Program.Types + ( -- * Program and functions for constructing them + Program (..) + , ProgramSearchPath + , ProgramSearchPathEntry (..) -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - suppressOverrideArgs, - ProgArg, - ProgramLocation(..), - simpleConfiguredProgram, + , ConfiguredProgram (..) + , programPath + , suppressOverrideArgs + , ProgArg + , ProgramLocation (..) + , simpleConfiguredProgram ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.PackageDescription -import Distribution.Simple.Program.Find -import Distribution.Version import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map @@ -50,88 +46,107 @@ -- -- Note: rather than constructing this directly, start with 'simpleProgram' and -- override any extra fields. --- -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if its location was not - -- specified by the user. Usually this will just be a call to - -- 'findProgramOnSearchPath'. - -- - -- It is supplied with the prevailing search path which will typically - -- just be used as-is, but can be extended or ignored as needed. - -- - -- For the purpose of change monitoring, in addition to the location - -- where the program was found, it returns all the other places that - -- were tried. - -- - programFindLocation :: Verbosity -> ProgramSearchPath - -> IO (Maybe (FilePath, [FilePath])), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's OK to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), +data Program = Program + { programName :: String + -- ^ The simple name of the program, eg. ghc + , programFindLocation + :: Verbosity + -> ProgramSearchPath + -> IO (Maybe (FilePath, [FilePath])) + -- ^ A function to search for the program if its location was not + -- specified by the user. Usually this will just be a call to + -- 'findProgramOnSearchPath'. + -- + -- It is supplied with the prevailing search path which will typically + -- just be used as-is, but can be extended or ignored as needed. + -- + -- For the purpose of change monitoring, in addition to the location + -- where the program was found, it returns all the other places that + -- were tried. + , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version) + -- ^ Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's OK to return Nothing. + , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram + -- ^ A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). For example + -- it could add args, or environment vars. + , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] + -- ^ A function that filters any arguments that don't impact the output + -- from a commandline. Used to limit the volatility of dependency hashes + -- when using new-build. + } - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). For example - -- it could add args, or environment vars. - programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram, - -- | A function that filters any arguments that don't impact the output - -- from a commandline. Used to limit the volatility of dependency hashes - -- when using new-build. - programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String] - } instance Show Program where show (Program name _ _ _ _) = "Program: " ++ name type ProgArg = String --- | Represents a program which has been configured and is thus ready to be run. +-- | A search path to use when locating executables. This is analogous +-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use +-- the system default method for finding executables ('findExecutable' which +-- on unix is simply looking on the @$PATH@ but on win32 is a bit more +-- complicated). -- --- These are usually made by configuring a 'Program', but if you have to --- construct one directly then start with 'simpleConfiguredProgram' and --- override any extra fields. +-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs +-- either before, after or instead of the default, e.g. here we add an extra +-- dir to search after the usual ones. -- -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Override environment variables for this program. - -- These env vars will extend\/override the prevailing environment of - -- the current to form the environment for the new process. - programOverrideEnv :: [(String, Maybe String)], +-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir] +-- +-- We also use this path to set the environment when running child processes. +-- +-- The @ProgramDb@ is created with a @ProgramSearchPath@ to which we +-- @prependProgramSearchPath@ to add the ones that come from cli flags and from +-- configurations. Then each of the programs that are configured in the db +-- inherits the same path as part of @configureProgram@. +type ProgramSearchPath = [ProgramSearchPathEntry] - -- | A key-value map listing various properties of the program, useful - -- for feature detection. Populated during the configuration step, key - -- names depend on the specific program. - programProperties :: Map.Map String String, +data ProgramSearchPathEntry + = -- | A specific dir + ProgramSearchPathDir FilePath + | -- | The system default + ProgramSearchPathDefault + deriving (Show, Eq, Generic) - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation, +instance Binary ProgramSearchPathEntry +instance Structured ProgramSearchPathEntry - -- | In addition to the 'programLocation' where the program was found, - -- these are additional locations that were looked at. The combination - -- of ths found location and these not-found locations can be used to - -- monitor to detect when the re-configuring the program might give a - -- different result (e.g. found in a different location). - -- - programMonitorFiles :: [FilePath] - } - deriving (Eq, Generic, Read, Show, Typeable) +-- | Represents a program which has been configured and is thus ready to be run. +-- +-- These are usually made by configuring a 'Program', but if you have to +-- construct one directly then start with 'simpleConfiguredProgram' and +-- override any extra fields. +data ConfiguredProgram = ConfiguredProgram + { programId :: String + -- ^ Just the name again + , programVersion :: Maybe Version + -- ^ The version of this program, if it is known. + , programDefaultArgs :: [String] + -- ^ Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + , programOverrideArgs :: [String] + -- ^ Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + , programOverrideEnv :: [(String, Maybe String)] + -- ^ Override environment variables for this program. + -- These env vars will extend\/override the prevailing environment of + -- the current to form the environment for the new process. + , programProperties :: Map.Map String String + -- ^ A key-value map listing various properties of the program, useful + -- for feature detection. Populated during the configuration step, key + -- names depend on the specific program. + , programLocation :: ProgramLocation + -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + , programMonitorFiles :: [FilePath] + -- ^ In addition to the 'programLocation' where the program was found, + -- these are additional locations that were looked at. The combination + -- of this found location and these not-found locations can be used to + -- monitor to detect when the re-configuring the program might give a + -- different result (e.g. found in a different location). + } + deriving (Eq, Generic, Read, Show) instance Binary ConfiguredProgram instance Structured ConfiguredProgram @@ -139,12 +154,12 @@ -- | Where a program was found. Also tells us whether it's specified by user or -- not. This includes not just the path, but the program as well. data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The program was found automatically. - deriving (Eq, Generic, Read, Show, Typeable) + = -- | The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + UserSpecified {locationPath :: FilePath} + | -- | The program was found automatically. + FoundOnSystem {locationPath :: FilePath} + deriving (Eq, Generic, Read, Show) instance Binary ProgramLocation instance Structured ProgramLocation @@ -155,36 +170,20 @@ -- | Suppress any extra arguments added by the user. suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram -suppressOverrideArgs prog = prog { programOverrideArgs = [] } - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v p -> findProgramOnSearchPath v p name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ p -> return p, - programNormaliseArgs = \_ _ -> id - } +suppressOverrideArgs prog = prog{programOverrideArgs = []} -- | Make a simple 'ConfiguredProgram'. -- -- > simpleConfiguredProgram "foo" (FoundOnSystem path) --- simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram -simpleConfiguredProgram name loc = ConfiguredProgram { - programId = name, - programVersion = Nothing, - programDefaultArgs = [], - programOverrideArgs = [], - programOverrideEnv = [], - programProperties = Map.empty, - programLocation = loc, - programMonitorFiles = [] -- did not look in any other locations - } +simpleConfiguredProgram name loc = + ConfiguredProgram + { programId = name + , programVersion = Nothing + , programDefaultArgs = [] + , programOverrideArgs = [] + , programOverrideEnv = [] + , programProperties = Map.empty + , programLocation = loc + , programMonitorFiles = [] -- did not look in any other locations + } diff --git a/src/Distribution/Simple/Register.hs b/src/Distribution/Simple/Register.hs --- a/src/Distribution/Simple/Register.hs +++ b/src/Distribution/Simple/Register.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Register -- Copyright : Isaac Jones 2003-2004 @@ -25,164 +27,198 @@ -- This module does not delegate anything to the per-compiler modules but just -- mixes it all in this module, which is rather unsatisfactory. The script -- generation and the unregister feature are not well used or tested. - -module Distribution.Simple.Register ( - register, - unregister, - - internalPackageDBPath, - - initPackageDB, - doesPackageDBExist, - createPackageDB, - deletePackageDB, - - abiHash, - invokeHcPkg, - registerPackage, - HcPkg.RegisterOptions(..), - HcPkg.defaultRegisterOptions, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, +module Distribution.Simple.Register + ( register + , unregister + , internalPackageDBPath + , initPackageDB + , doesPackageDBExist + , createPackageDB + , deletePackageDB + , abiHash + , invokeHcPkg + , registerPackage + , HcPkg.RegisterOptions (..) + , HcPkg.defaultRegisterOptions + , generateRegistrationInfo + , inplaceInstalledPackageInfo + , absoluteInstalledPackageInfo + , generalInstalledPackageInfo ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.TargetInfo -import Distribution.Types.LocalBuildInfo import Distribution.Types.ComponentLocalBuildInfo +import Distribution.Types.LocalBuildInfo +import Distribution.Types.TargetInfo -import Distribution.Simple.LocalBuildInfo import Distribution.Simple.BuildPaths import Distribution.Simple.BuildTarget +import Distribution.Simple.LocalBuildInfo -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.GHCJS as GHCJS -import qualified Distribution.Simple.UHC as UHC -import qualified Distribution.Simple.HaskellSuite as HaskellSuite import qualified Distribution.Simple.PackageIndex as Index +import qualified Distribution.Simple.UHC as UHC import Distribution.Backpack.DescribeUnitId +import Distribution.Compat.Graph (IsNode (nodeKey)) +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.License (licenseFromSPDX, licenseToSPDX) +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Pretty import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag import Distribution.Simple.Program -import Distribution.Simple.Program.Script import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Setup -import Distribution.PackageDescription -import Distribution.Package -import Distribution.License (licenseToSPDX, licenseFromSPDX) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.Program.Script +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Register import Distribution.Simple.Utils -import Distribution.Utils.MapAccum import Distribution.System -import Distribution.Pretty +import Distribution.Utils.MapAccum +import Distribution.Utils.Path import Distribution.Verbosity as Verbosity import Distribution.Version -import Distribution.Compat.Graph (IsNode(nodeKey)) - -import System.FilePath ((), (<.>), isAbsolute) import System.Directory +import System.FilePath (isAbsolute) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -- ----------------------------------------------------------------------------- -- Registration -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg_descr lbi0 flags = - -- Duncan originally asked for us to not register/install files - -- when there was no public library. But with per-component - -- configure, we legitimately need to install internal libraries - -- so that we can get them. So just unconditionally install. - doRegister - where - doRegister = do - targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags) +register + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -- ^ Install in the user's database?; verbose + -> IO () +register pkg_descr lbi0 flags = do + -- Duncan originally asked for us to not register/install files + -- when there was no public library. But with per-component + -- configure, we legitimately need to install internal libraries + -- so that we can get them. So just unconditionally install. + let verbosity = fromFlag $ registerVerbosity flags + targets <- readTargetInfos verbosity pkg_descr lbi0 $ registerTargets flags - -- It's important to register in build order, because ghc-pkg - -- will complain if a dependency is not registered. - let componentsToRegister - = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) + -- It's important to register in build order, because ghc-pkg + -- will complain if a dependency is not registered. + let componentsToRegister = + neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets) - (_, ipi_mbs) <- - mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> - case targetComponent tgt of - CLib lib -> do - let clbi = targetCLBI tgt - lbi = lbi0 { installedPkgs = index } - ipi <- generateOne pkg_descr lib lbi clbi flags - return (Index.insert ipi index, Just ipi) - _ -> return (index, Nothing) + (_, ipi_mbs) <- + mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt -> + case targetComponent tgt of + CLib lib -> do + let clbi = targetCLBI tgt + lbi = lbi0{installedPkgs = index} + ipi <- generateOne pkg_descr lib lbi clbi flags + return (Index.insert ipi index, Just ipi) + _ -> return (index, Nothing) - registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) - where - verbosity = fromFlag (regVerbosity flags) + registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs) -generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo - -> RegisterFlags - -> IO InstalledPackageInfo -generateOne pkg lib lbi clbi regFlags - = do - absPackageDBs <- absolutePackageDBPaths packageDbs - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace reloc distPref - (registrationPackageDB absPackageDBs) +generateOne + :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> RegisterFlags + -> IO InstalledPackageInfo +generateOne pkg lib lbi clbi regFlags = + do + absPackageDBs <- absolutePackageDBPaths mbWorkDir packageDbs + installedPkgInfo <- + generateRegistrationInfo + verbosity + pkg + lib + lbi + clbi + inplace + reloc + distPref + (registrationPackageDB absPackageDBs) info verbosity (IPI.showInstalledPackageInfo installedPkgInfo) return installedPkgInfo where - inplace = fromFlag (regInPlace regFlags) - reloc = relocatable lbi + common = registerCommonFlags regFlags + inplace = fromFlag (regInPlace regFlags) + reloc = relocatable lbi -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common -registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags - -> [InstalledPackageInfo] - -> IO () -registerAll pkg lbi regFlags ipis - = do +registerAll + :: PackageDescription + -> LocalBuildInfo + -> RegisterFlags + -> [InstalledPackageInfo] + -> IO () +registerAll pkg lbi regFlags ipis = + do when (fromFlag (regPrintId regFlags)) $ do for_ ipis $ \installedPkgInfo -> -- Only print the public library's IPI - when (packageId installedPkgInfo == packageId pkg - && IPI.sourceLibName installedPkgInfo == LMainLibName) $ - putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) + when + ( packageId installedPkgInfo == packageId pkg + && IPI.sourceLibName installedPkgInfo == LMainLibName + ) + $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo)) - -- Three different modes: + -- Three different modes: case () of - _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory - | modeGenerateRegScript -> writeRegisterScript - | otherwise -> do - for_ ipis $ \ipi -> do - setupMessage' verbosity "Registering" (packageId pkg) - (CLibName (IPI.sourceLibName ipi)) - (Just (IPI.instantiatedWith ipi)) - registerPackage verbosity (compiler lbi) (withPrograms lbi) - packageDbs ipi HcPkg.defaultRegisterOptions - + _ + | modeGenerateRegFile -> writeRegistrationFileOrDirectory + | modeGenerateRegScript -> writeRegisterScript + | otherwise -> do + for_ ipis $ \ipi -> do + setupMessage' + verbosity + "Registering" + (packageId pkg) + (CLibName (IPI.sourceLibName ipi)) + (Just (IPI.instantiatedWith ipi)) + registerPackage + verbosity + (compiler lbi) + (withPrograms lbi) + (mbWorkDirLBI lbi) + packageDbs + ipi + HcPkg.defaultRegisterOptions where modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) + regFile = + interpretSymbolicPathLBI lbi $ + fromMaybe + (makeSymbolicPath (prettyShow (packageId pkg) <.> "conf")) + (fromFlag (regGenPkgConf regFlags)) modeGenerateRegScript = fromFlag (regGenScript regFlags) -- FIXME: there's really no guarantee this will work. -- registering into a totally different db stack can -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - verbosity = fromFlag (regVerbosity regFlags) + packageDbs = + nub $ + withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + common = registerCommonFlags regFlags + verbosity = fromFlag (setupVerbosity common) + mbWorkDir = mbWorkDirLBI lbi writeRegistrationFileOrDirectory = do -- Handles overwriting both directory and file @@ -196,195 +232,255 @@ createDirectory regFile let num_ipis = length ipis lpad m xs = replicate (m - length ys) '0' ++ ys - where ys = take m xs + where + ys = take m xs number i = lpad (length (show num_ipis)) (show i) - for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> - writeUTF8File (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) - (IPI.showInstalledPackageInfo installedPkgInfo) + for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) -> + writeUTF8File + (regFile (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo))) + (IPI.showInstalledPackageInfo installedPkgInfo) writeRegisterScript = case compilerFlavor (compiler lbi) of UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> withHcPkg verbosity - "Registration scripts are not implemented for this compiler" - (compiler lbi) (withPrograms lbi) - (writeHcPkgRegisterScript verbosity ipis packageDbs) - + _ -> + withHcPkg + verbosity + "Registration scripts are not implemented for this compiler" + (compiler lbi) + (withPrograms lbi) + (writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs) -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> Bool - -> FilePath - -> PackageDB - -> IO InstalledPackageInfo +generateRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> Bool + -> SymbolicPath Pkg (Dir Dist) + -> PackageDB + -> IO InstalledPackageInfo generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do - --TODO: eliminate pwd! - pwd <- getCurrentDirectory - + inplaceDir <- absoluteWorkingDirLBI lbi installedPkgInfo <- if inplace - -- NB: With an inplace installation, the user may run './Setup + then -- NB: With an inplace installation, the user may run './Setup -- build' to update the library files, without reregistering. -- In this case, it is critical that the ABI hash not flip. - then return (inplaceInstalledPackageInfo pwd distPref - pkg (mkAbiHash "inplace") lib lbi clbi) - else do + + return + ( inplaceInstalledPackageInfo + inplaceDir + distPref + pkg + (mkAbiHash "inplace") + lib + lbi + clbi + ) + else do abi_hash <- abiHash verbosity pkg distPref lbi lib clbi if reloc - then relocRegistrationInfo verbosity - pkg lib lbi clbi abi_hash packageDb - else return (absoluteInstalledPackageInfo - pkg abi_hash lib lbi clbi) - + then + relocRegistrationInfo + verbosity + pkg + lib + lbi + clbi + abi_hash + packageDb + else + return + ( absoluteInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + ) return installedPkgInfo -- | Compute the 'AbiHash' of a library that we built inplace. -abiHash :: Verbosity - -> PackageDescription - -> FilePath - -> LocalBuildInfo - -> Library - -> ComponentLocalBuildInfo - -> IO AbiHash +abiHash + :: Verbosity + -> PackageDescription + -> SymbolicPath Pkg (Dir Dist) + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO AbiHash abiHash verbosity pkg distPref lbi lib clbi = - case compilerFlavor comp of - GHC -> do - fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi - GHCJS -> do - fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi - _ -> return (mkAbiHash "") + case compilerFlavor comp of + GHC -> do + fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi + GHCJS -> do + fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi + _ -> return (mkAbiHash "") where comp = compiler lbi - lbi' = lbi { - withPackageDB = withPackageDB lbi - ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] - } + lbi' = + lbi + { withPackageDB = + withPackageDB lbi + ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)] + } -relocRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> AbiHash - -> PackageDB - -> IO InstalledPackageInfo +relocRegistrationInfo + :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> AbiHash + -> PackageDB + -> IO InstalledPackageInfo relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = case (compilerFlavor (compiler lbi)) of - GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb - return (relocatableInstalledPackageInfo - pkg abi_hash lib lbi clbi fs) - _ -> die' verbosity - "Distribution.Simple.Register.relocRegistrationInfo: \ - \not implemented for this compiler" + GHC -> do + fs <- GHC.pkgRoot verbosity lbi packageDb + return + ( relocatableInstalledPackageInfo + pkg + abi_hash + lib + lbi + clbi + fs + ) + _ -> dieWithException verbosity RelocRegistrationInfo initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO () initPackageDB verbosity comp progdb dbPath = - createPackageDB verbosity comp progdb False dbPath + createPackageDB verbosity comp progdb False dbPath -- | Create an empty package DB at the specified location. -createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool - -> FilePath -> IO () +createPackageDB + :: Verbosity + -> Compiler + -> ProgramDb + -> Bool + -> FilePath + -> IO () createPackageDB verbosity comp progdb preferCompat dbPath = - case compilerFlavor comp of - GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath - GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath - UHC -> return () - HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath - _ -> die' verbosity $ - "Distribution.Simple.Register.createPackageDB: " - ++ "not implemented for this compiler" + case compilerFlavor comp of + GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath + GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath + UHC -> return () + _ -> dieWithException verbosity CreatePackageDB doesPackageDBExist :: FilePath -> IO Bool doesPackageDBExist dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then return True - else doesFileExist dbPath + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then return True + else doesFileExist dbPath deletePackageDB :: FilePath -> IO () deletePackageDB dbPath = do - -- currently one impl for all compiler flavours, but could change if needed - dir_exists <- doesDirectoryExist dbPath - if dir_exists - then removeDirectoryRecursive dbPath - else do file_exists <- doesFileExist dbPath - when file_exists $ removeFile dbPath + -- currently one impl for all compiler flavours, but could change if needed + dir_exists <- doesDirectoryExist dbPath + if dir_exists + then removeDirectoryRecursive dbPath + else do + file_exists <- doesFileExist dbPath + when file_exists $ removeFile dbPath -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- provided command-line arguments to it. -invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack - -> [String] -> IO () -invokeHcPkg verbosity comp progdb dbStack extraArgs = - withHcPkg verbosity "invokeHcPkg" comp progdb - (\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs) +invokeHcPkg + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> PackageDBStack + -> [String] + -> IO () +invokeHcPkg verbosity comp progdb mbWorkDir dbStack extraArgs = + withHcPkg + verbosity + "invokeHcPkg" + comp + progdb + (\hpi -> HcPkg.invoke hpi verbosity mbWorkDir dbStack extraArgs) -withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb - -> (HcPkg.HcPkgInfo -> IO a) -> IO a +withHcPkg + :: Verbosity + -> String + -> Compiler + -> ProgramDb + -> (HcPkg.HcPkgInfo -> IO a) + -> IO a withHcPkg verbosity name comp progdb f = case compilerFlavor comp of - GHC -> f (GHC.hcPkgInfo progdb) + GHC -> f (GHC.hcPkgInfo progdb) GHCJS -> f (GHCJS.hcPkgInfo progdb) - _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\ - \not implemented for this compiler") + _ -> dieWithException verbosity $ WithHcPkg name -registerPackage :: Verbosity - -> Compiler - -> ProgramDb - -> PackageDBStack - -> InstalledPackageInfo - -> HcPkg.RegisterOptions - -> IO () -registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions = +registerPackage + :: Verbosity + -> Compiler + -> ProgramDb + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackS from + -> InstalledPackageInfo + -> HcPkg.RegisterOptions + -> IO () +registerPackage verbosity comp progdb mbWorkDir packageDbs installedPkgInfo registerOptions = case compilerFlavor comp of - GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions - HaskellSuite {} -> - HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo - _ | HcPkg.registerMultiInstance registerOptions - -> die' verbosity "Registering multiple package instances is not yet supported for this compiler" - UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo - _ -> die' verbosity "Registering is not implemented for this compiler" + GHC -> GHC.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions + GHCJS -> GHCJS.registerPackage verbosity progdb mbWorkDir packageDbs installedPkgInfo registerOptions + _ + | HcPkg.registerMultiInstance registerOptions -> + dieWithException verbosity RegisMultiplePkgNotSupported + UHC -> UHC.registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo + _ -> dieWithException verbosity RegisteringNotImplemented -writeHcPkgRegisterScript :: Verbosity - -> [InstalledPackageInfo] - -> PackageDBStack - -> HcPkg.HcPkgInfo - -> IO () -writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do +writeHcPkgRegisterScript + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [InstalledPackageInfo] + -> PackageDBStack + -> HcPkg.HcPkgInfo + -> IO () +writeHcPkgRegisterScript verbosity mbWorkDir ipis packageDbs hpi = do let genScript installedPkgInfo = - let invocation = HcPkg.registerInvocation hpi Verbosity.normal - packageDbs installedPkgInfo - HcPkg.defaultRegisterOptions - in invocationAsSystemScript buildOS invocation + let invocation = + HcPkg.registerInvocation + hpi + Verbosity.normal + mbWorkDir + packageDbs + installedPkgInfo + HcPkg.defaultRegisterOptions + in invocationAsSystemScript buildOS invocation scripts = map genScript ipis -- TODO: Do something more robust here regScript = unlines scripts - info verbosity ("Creating package registration script: " ++ regScriptFileName) - writeUTF8File regScriptFileName regScript - setFileExecutable regScriptFileName + let out_file = interpretSymbolicPath mbWorkDir regScriptFileName + info verbosity ("Creating package registration script: " ++ out_file) + writeUTF8File out_file regScript + setFileExecutable out_file -regScriptFileName :: FilePath +regScriptFileName :: SymbolicPath Pkg File regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - + Windows -> makeSymbolicPath "register.bat" + _ -> makeSymbolicPath "register.sh" -- ----------------------------------------------------------------------------- -- Making the InstalledPackageInfo -- | Construct 'InstalledPackageInfo' for a library in a package, given a set -- of installation directories. --- generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. + :: ([FilePath] -> [FilePath]) + -- ^ Translate relative include dir paths to + -- absolute paths. -> PackageDescription -> AbiHash -> Library @@ -393,203 +489,267 @@ -> InstallDirs FilePath -> InstalledPackageInfo generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs = - IPI.InstalledPackageInfo { - IPI.sourcePackageId = packageId pkg, - IPI.installedUnitId = componentUnitId clbi, - IPI.installedComponentId_ = componentComponentId clbi, - IPI.instantiatedWith = componentInstantiatedWith clbi, - IPI.sourceLibName = libName lib, - IPI.compatPackageKey = componentCompatPackageKey clbi, - -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license - IPI.license = + IPI.InstalledPackageInfo + { IPI.sourcePackageId = packageId pkg + , IPI.installedUnitId = componentUnitId clbi + , IPI.installedComponentId_ = componentComponentId clbi + , IPI.instantiatedWith = expectLibraryComponent (maybeComponentInstantiatedWith clbi) + , IPI.sourceLibName = libName lib + , IPI.compatPackageKey = expectLibraryComponent (maybeComponentCompatPackageKey clbi) + , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license + IPI.license = if ghc84 - then Left $ either id licenseToSPDX $ licenseRaw pkg - else Right $ either licenseFromSPDX id $ licenseRaw pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.synopsis = synopsis pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.abiHash = abi_hash, - IPI.indefinite = componentIsIndefinite clbi, - IPI.exposed = libExposed lib, - IPI.exposedModules = componentExposedModules clbi - -- add virtual modules into the list of exposed modules for the - -- package database as well. - ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi), - IPI.hiddenModules = otherModules bi, - IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = libdirs, - IPI.libraryDynDirs = dynlibdirs, - IPI.dataDir = datadir installDirs, - IPI.hsLibraries = (if hasLibrary - then [getHSLibraryName (componentUnitId clbi)] - else []) ++ extraBundledLibs bi, - IPI.extraLibraries = extraLibs bi, - IPI.extraGHCiLibraries = extraGHCiLibs bi, - IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, - IPI.includes = includes bi, - IPI.depends = depends, - IPI.abiDepends = [], -- due to #5465 - IPI.ccOptions = [], -- Note. NOT ccOptions bi! - -- We don't want cc-options to be propagated - -- to C compilations in other packages. - IPI.cxxOptions = [], -- Also. NOT cxxOptions bi! - IPI.ldOptions = ldOptions bi, - IPI.frameworks = frameworks bi, - IPI.frameworkDirs = extraFrameworkDirs bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs], - IPI.pkgRoot = Nothing, - IPI.libVisibility = libVisibility lib - } + then Left $ either id licenseToSPDX $ licenseRaw pkg + else Right $ either licenseFromSPDX id $ licenseRaw pkg + , IPI.copyright = copyright pkg + , IPI.maintainer = maintainer pkg + , IPI.author = author pkg + , IPI.stability = stability pkg + , IPI.homepage = homepage pkg + , IPI.pkgUrl = pkgUrl pkg + , IPI.synopsis = synopsis pkg + , IPI.description = description pkg + , IPI.category = category pkg + , IPI.abiHash = abi_hash + , IPI.indefinite = componentIsIndefinite clbi + , IPI.exposed = libExposed lib + , IPI.exposedModules = + expectLibraryComponent (maybeComponentExposedModules clbi) + -- add virtual modules into the list of exposed modules for the + -- package database as well. + ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi) + , IPI.hiddenModules = otherModules bi + , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo + , IPI.importDirs = [libdir installDirs | hasModules] + , IPI.libraryDirs = libdirs + , IPI.libraryDirsStatic = libdirsStatic + , IPI.libraryDynDirs = dynlibdirs + , IPI.dataDir = datadir installDirs + , IPI.hsLibraries = + ( if hasLibrary + then [getHSLibraryName (componentUnitId clbi)] + else [] + ) + ++ extraBundledLibs bi + , IPI.extraLibraries = extraLibs bi + , IPI.extraLibrariesStatic = extraLibsStatic bi + , IPI.extraGHCiLibraries = extraGHCiLibs bi + , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc + , IPI.includes = map getSymbolicPath $ includes bi + , IPI.depends = depends + , IPI.abiDepends = [] -- due to #5465 + , IPI.ccOptions = [] -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi! + , IPI.ldOptions = ldOptions bi + , IPI.frameworks = map getSymbolicPath $ frameworks bi + , IPI.frameworkDirs = map getSymbolicPath $ extraFrameworkDirs bi + , IPI.haddockInterfaces = [haddockdir installDirs haddockLibraryPath pkg lib | hasModules] + , IPI.haddockHTMLs = [htmldir installDirs | hasModules] + , IPI.pkgRoot = Nothing + , IPI.libVisibility = libVisibility lib + } where ghc84 = case compilerId $ compiler lbi of - CompilerId GHC v -> v >= mkVersion [8, 4] - _ -> False + CompilerId GHC v -> v >= mkVersion [8, 4] + _ -> False bi = libBuildInfo lib - --TODO: unclear what the root cause of the + -- TODO: unclear what the root cause of the -- duplication is, but we nub it here for now: depends = ordNub $ map fst (componentPackageDeps clbi) - (absinc, relinc) = partition isAbsolute (includeDirs bi) + (absinc, relinc) = partition isAbsolute (map getSymbolicPath $ includeDirs bi) hasModules = not $ null (allLibModules lib clbi) comp = compiler lbi - hasLibrary = (hasModules || not (null (cSources bi)) - || not (null (asmSources bi)) - || not (null (cmmSources bi)) - || not (null (cxxSources bi)) - || (not (null (jsSources bi)) && - compilerFlavor comp == GHCJS)) - && not (componentIsIndefinite clbi) + hasLibrary = + ( hasModules + || not (null (cSources bi)) + || not (null (asmSources bi)) + || not (null (cmmSources bi)) + || not (null (cxxSources bi)) + || (not (null (jsSources bi)) && hasJsSupport) + ) + && not (componentIsIndefinite clbi) + hasJsSupport = case hostPlatform lbi of + Platform JavaScript _ -> True + _ -> False + extraLibDirs' = map getSymbolicPath $ extraLibDirs bi + libdirsStatic + | hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback + | otherwise = extraLibDirsStaticOrFallback + where + -- If no static library dirs were given, the package likely makes no + -- distinction between fully static linking and otherwise. + -- Fall back to the normal library dirs in that case. + extraLibDirsStaticOrFallback = case extraLibDirsStatic bi of + [] -> extraLibDirs' + dirs -> map getSymbolicPath dirs (libdirs, dynlibdirs) - | not hasLibrary - = (extraLibDirs bi, []) + | not hasLibrary = + (extraLibDirs', []) -- the dynamic-library-dirs defaults to the library-dirs if not specified, -- so this works whether the dynamic-library-dirs field is supported or not - | libraryDynDirSupported comp - = (libdir installDirs : extraLibDirs bi, - dynlibdir installDirs : extraLibDirs bi) + | libraryDynDirSupported comp = + ( libdir installDirs : extraLibDirs' + , dynlibdir installDirs : extraLibDirs' + ) + | otherwise = + (libdir installDirs : dynlibdir installDirs : extraLibDirs', []) + expectLibraryComponent (Just attribute) = attribute + expectLibraryComponent Nothing = (error "generalInstalledPackageInfo: Expected a library component, got something else.") - | otherwise - = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, []) - -- the compiler doesn't understand the dynamic-library-dirs field so we - -- add the dyn directory to the "normal" list in the library-dirs field +-- the compiler doesn't understand the dynamic-library-dirs field so we +-- add the dyn directory to the "normal" list in the library-dirs field -- | Construct 'InstalledPackageInfo' for a library that is in place in the -- build tree. -- -- This function knows about the layout of in place packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +inplaceInstalledPackageInfo + :: AbsolutePath (Dir Pkg) + -> SymbolicPath Pkg (Dir Dist) + -- ^ location of the dist tree + -> PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustRelativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustRelativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where + i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path adjustRelativeIncludeDirs = concatMap $ \d -> - [ inplaceDir d -- local include-dir - , inplaceDir libTargetDir d -- autogen include-dir + [ i $ makeRelativePathEx d -- local include-dir + , i $ libTargetDir makeRelativePathEx d -- autogen include-dir ] libTargetDir = componentBuildDir lbi clbi installDirs = - (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) { - libdir = inplaceDir libTargetDir, - dynlibdir = inplaceDir libTargetDir, - datadir = inplaceDir dataDir pkg, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" - inplaceHtmldir = inplaceDocdir "html" prettyShow (packageName pkg) - + (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) + { libdir = i libTargetDir + , dynlibdir = i libTargetDir + , datadir = + let rawDataDir = dataDir pkg + in if null $ getSymbolicPath rawDataDir + then i sameDirectory + else i rawDataDir + , docdir = i inplaceDocdir + , htmldir = inplaceHtmldir + , haddockdir = inplaceHtmldir + } + inplaceDocdir = distPref makeRelativePathEx "doc" + inplaceHtmldir = i $ inplaceDocdir makeRelativePathEx ("html" prettyShow (packageName pkg)) -- | Construct 'InstalledPackageInfo' for the final install location of a -- library package. -- -- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo +absoluteInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest - -relocatableInstalledPackageInfo :: PackageDescription - -> AbiHash - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> InstalledPackageInfo +relocatableInstalledPackageInfo + :: PackageDescription + -> AbiHash + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath CWD ('Dir Pkg) + -> InstalledPackageInfo relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot = - generalInstalledPackageInfo adjustReativeIncludeDirs - pkg abi_hash lib lbi clbi installDirs + generalInstalledPackageInfo + adjustReativeIncludeDirs + pkg + abi_hash + lib + lbi + clbi + installDirs where -- For installed packages we install all include files into one dir, -- whereas in the build tree they may live in multiple local dirs. adjustReativeIncludeDirs _ | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] + | otherwise = [includedir installDirs] bi = libBuildInfo lib - installDirs = fmap (("${pkgroot}" ) . shortRelativePath pkgroot) - $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest + installDirs = + fmap (("${pkgroot}" ) . shortRelativePath (getSymbolicPath pkgroot)) $ + absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest -- ----------------------------------------------------------------------------- -- Unregistration unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () unregister pkg lbi regFlags = do - let pkgid = packageId pkg + let pkgid = packageId pkg + common = registerCommonFlags regFlags genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) + verbosity = fromFlag (setupVerbosity common) + packageDb = + fromFlagOrDefault + (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + mbWorkDir = mbWorkDirLBI lbi unreg hpi = - let invocation = HcPkg.unregisterInvocation - hpi Verbosity.normal packageDb pkgid - in if genScript - then writeFileAtomic unregScriptFileName - (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) - else runProgramInvocation verbosity invocation + let invocation = + HcPkg.unregisterInvocation + hpi + Verbosity.normal + mbWorkDir + packageDb + pkgid + in if genScript + then + writeFileAtomic + unregScriptFileName + (BS.Char8.pack $ invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation setupMessage verbosity "Unregistering" pkgid - withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS" - (compiler lbi) (withPrograms lbi) unreg + withHcPkg + verbosity + "unregistering is only implemented for GHC and GHCJS" + (compiler lbi) + (withPrograms lbi) + unreg unregScriptFileName :: FilePath unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" + Windows -> "unregister.bat" + _ -> "unregister.sh" -internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath +internalPackageDBPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) -> SymbolicPath Pkg (Dir PkgDB) internalPackageDBPath lbi distPref = - case compilerFlavor (compiler lbi) of - UHC -> UHC.inplacePackageDbPath lbi - _ -> distPref "package.conf.inplace" + case compilerFlavor (compiler lbi) of + UHC -> UHC.inplacePackageDbPath lbi + _ -> distPref makeRelativePathEx "package.conf.inplace" diff --git a/src/Distribution/Simple/Setup.hs b/src/Distribution/Simple/Setup.hs --- a/src/Distribution/Simple/Setup.hs +++ b/src/Distribution/Simple/Setup.hs @@ -1,2348 +1,251 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a big module, but not very complicated. The code is very regular --- and repetitive. It defines the command line interface for all the Cabal --- commands. For each command (like @configure@, @build@ etc) it defines a type --- that holds all the flags, the default set of flags and a 'CommandUI' that --- maps command line flags to and from the corresponding flags type. --- --- All the flags types are instances of 'Monoid', see --- --- for an explanation. --- --- The types defined here get used in the front end and especially in --- @cabal-install@ which has to do quite a bit of manipulating sets of command --- line flags. --- --- This is actually relatively nice, it works quite well. The main change it --- needs is to unify it with the code for managing sets of fields that can be --- read and written from files. This would allow us to save configure flags in --- config files. - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - configPrograms, - configAbsolutePaths, readPackageDbList, showPackageDbList, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockTarget(..), - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - ShowBuildInfoFlags(..), defaultShowBuildFlags, showBuildInfoCommand, - ReplFlags(..), defaultReplFlags, replCommand, - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - BenchmarkFlags(..), emptyBenchmarkFlags, - defaultBenchmarkFlags, benchmarkCommand, - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - buildOptions, haddockOptions, installDirsOptions, - testOptions', benchmarkOptions', - programDbOptions, programDbPaths', - programFlagsDescription, - replOptions, - splitArgs, - - defaultDistPref, optionDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - maybeToFlag, - BooleanFlag(..), - boolOpt, boolOpt', trueArg, falseArg, - optionVerbosity, optionNumJobs) where - -import Prelude () -import Distribution.Compat.Prelude hiding (get) - -import Distribution.Compiler -import Distribution.ReadE -import Distribution.Parsec -import Distribution.Pretty -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.ModuleName -import Distribution.PackageDescription -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler -import Distribution.Simple.Flag -import Distribution.Simple.Utils -import Distribution.Simple.Program -import Distribution.Simple.InstallDirs -import Distribution.Verbosity -import Distribution.Utils.NubList -import Distribution.Types.ComponentId -import Distribution.Types.GivenComponent -import Distribution.Types.Module -import Distribution.Types.PackageVersionConstraint - -import Distribution.Compat.Stack -import Distribution.Compat.Semigroup (Last' (..), Option' (..)) - --- FIXME Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } deriving (Generic, Typeable) - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: [Command action] -> CommandUI GlobalFlags -globalCommand commands = CommandUI - { commandName = "" - , commandSynopsis = "" - , commandUsage = \pname -> - "This Setup program uses the Haskell Cabal Infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n" - ++ "\n" - ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n" - , commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - in - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ descr - | (name, descr) <- cmdDescs ] - ++ "\n" - ++ "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]] - , commandNotes = Nothing - , commandDefaultFlags = defaultGlobalFlags - , commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup GlobalFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command. --- --- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags' --- should be updated. --- IMPORTANT: every time a new flag is added, it should be added to the Eq instance -data ConfigFlags = ConfigFlags { - -- This is the same hack as in 'buildArgs' and 'copyArgs'. - -- TODO: Stop using this eventually when 'UserHooks' gets changed - configArgs :: [String], - - --FIXME: the configPrograms is only here to pass info through to configure - -- because the type of configure is constrained by the UserHooks. - -- when we change UserHooks next we should pass the initial - -- ProgramDb directly and not via ConfigFlags - configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that - -- @cabal@ may run - - configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths - configProgramArgs :: [(String, [String])], -- ^user specified programs args - configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the - -- compiler, e.g. GHC. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configStaticLib :: Flag Bool, -- ^Build static library - configDynExe :: Flag Bool, -- ^Enable dynamic linking of the - -- executables. - configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the - -- executables. - configProfExe :: Flag Bool, -- ^Enable profiling in the - -- executables. - configProf :: Flag Bool, -- ^Enable profiling in the library - -- and executables. - configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library and executables. - configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level - -- in the library - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation - -- paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra - -- frameworks (OS X only) - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - configIPID :: Flag String, -- ^ explicit IPID to be used - configCID :: Flag ComponentId, -- ^ explicit CID to be used - configDeterministic :: Flag Bool, -- ^ be as deterministic as possible - -- (e.g., invariant over GHC, database, - -- etc). Used by the test suite - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configStripLibs :: Flag Bool, -- ^Enable library stripping - configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for - -- dependencies. - configDependencies :: [GivenComponent], - -- ^The packages depended on. - configInstantiateWith :: [(ModuleName, Module)], - -- ^ The requested Backpack instantiation. If empty, either this - -- package does not use Backpack, or we just want to typecheck - -- the indefinite package. - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool, -- ^Enable test suite compilation - configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation - configCoverage :: Flag Bool, -- ^Enable program coverage - configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated) - configExactConfiguration :: Flag Bool, - -- ^All direct dependencies and flags are provided on the command line by - -- the user via the '--dependency' and '--flags' options. - configFlagError :: Flag String, - -- ^Halt and show an error message indicating an error in flag assignment - configRelocatable :: Flag Bool, -- ^ Enable relocatable package built - configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info. - configUseResponseFiles :: Flag Bool, - -- ^ Whether to use response files at all. They're used for such tools - -- as haddock, or ld. - configAllowDependingOnPrivateLibs :: Flag Bool - -- ^ Allow depending on private sublibraries. This is used by external - -- tools (like cabal-install) so they can add multiple-public-libraries - -- compatibility to older ghcs by checking visibility externally. - } - deriving (Generic, Read, Show, Typeable) - -instance Binary ConfigFlags -instance Structured ConfigFlags - --- | More convenient version of 'configPrograms'. Results in an --- 'error' if internal invariant is violated. -configPrograms :: WithCallStack (ConfigFlags -> ProgramDb) -configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast' - . getOption' . configPrograms_ - -instance Eq ConfigFlags where - (==) a b = - -- configPrograms skipped: not user specified, has no Eq instance - equal configProgramPaths - && equal configProgramArgs - && equal configProgramPathExtra - && equal configHcFlavor - && equal configHcPath - && equal configHcPkg - && equal configVanillaLib - && equal configProfLib - && equal configSharedLib - && equal configStaticLib - && equal configDynExe - && equal configFullyStaticExe - && equal configProfExe - && equal configProf - && equal configProfDetail - && equal configProfLibDetail - && equal configConfigureArgs - && equal configOptimization - && equal configProgPrefix - && equal configProgSuffix - && equal configInstallDirs - && equal configScratchDir - && equal configExtraLibDirs - && equal configExtraIncludeDirs - && equal configIPID - && equal configDeterministic - && equal configDistPref - && equal configVerbosity - && equal configUserInstall - && equal configPackageDBs - && equal configGHCiLib - && equal configSplitSections - && equal configSplitObjs - && equal configStripExes - && equal configStripLibs - && equal configConstraints - && equal configDependencies - && equal configConfigurationsFlags - && equal configTests - && equal configBenchmarks - && equal configCoverage - && equal configLibCoverage - && equal configExactConfiguration - && equal configFlagError - && equal configRelocatable - && equal configDebugInfo - && equal configUseResponseFiles - where - equal f = on (==) f a b - -configAbsolutePaths :: ConfigFlags -> IO ConfigFlags -configAbsolutePaths f = - (\v -> f { configPackageDBs = v }) - `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath)) - (configPackageDBs f) - -defaultConfigFlags :: ProgramDb -> ConfigFlags -defaultConfigFlags progDb = emptyConfigFlags { - configArgs = [], - configPrograms_ = Option' (Just (Last' progDb)), - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = NoFlag, - configSharedLib = NoFlag, - configStaticLib = NoFlag, - configDynExe = Flag False, - configFullyStaticExe = Flag False, - configProfExe = NoFlag, - configProf = NoFlag, - configProfDetail = NoFlag, - configProfLibDetail= NoFlag, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = NoFlag, - configCabalFilePath = NoFlag, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this -#if defined(mingw32_HOST_OS) - -- See #1589. - configGHCiLib = Flag True, -#else - configGHCiLib = NoFlag, -#endif - configSplitSections = Flag False, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = NoFlag, - configStripLibs = NoFlag, - configTests = Flag False, - configBenchmarks = Flag False, - configCoverage = Flag False, - configLibCoverage = NoFlag, - configExactConfiguration = Flag False, - configFlagError = NoFlag, - configRelocatable = Flag False, - configDebugInfo = Flag NoDebugInfo, - configUseResponseFiles = NoFlag - } - -configureCommand :: ProgramDb -> CommandUI ConfigFlags -configureCommand progDb = CommandUI - { commandName = "configure" - , commandSynopsis = "Prepare to build the package." - , commandDescription = Just $ \_ -> wrapText $ - "Configure how the package is built by setting " - ++ "package (and other) flags.\n" - ++ "\n" - ++ "The configuration affects several other commands, " - ++ "including build, test, bench, run, repl.\n" - , commandNotes = Just $ \_pname -> programFlagsDescription progDb - , commandUsage = \pname -> - "Usage: " ++ pname ++ " configure [FLAGS]\n" - , commandDefaultFlags = defaultConfigFlags progDb - , commandOptions = \showOrParseArgs -> - configureOptions showOrParseArgs - ++ programDbPaths progDb showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programDbOption progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - ++ programDbOptions progDb showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - } - --- | Inverse to 'dispModSubstEntry'. -parsecModSubstEntry :: ParsecParser (ModuleName, Module) -parsecModSubstEntry = do - k <- parsec - _ <- P.char '=' - v <- parsec - return (k, v) - --- | Pretty-print a single entry of a module substitution. -dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc -dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity - (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS") - , (Flag UHC, ([] , ["uhc"]), "compile with UHC") - -- "haskell-suite" compiler id string will be replaced - -- by a more specific one during the configure stage - , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]), - "compile with a haskell-suite compiler")]) - - ,option "" ["cabal-file"] - "use this Cabal file" - configCabalFilePath (\v flags -> flags { configCabalFilePath = v }) - (reqArgFlag "PATH") - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (reqArgFlag "PATH") - ] - ++ map liftInstallDirs installDirsOptions - ++ [option "" ["program-prefix"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["static"] - "Static library" - configStaticLib (\v flags -> flags { configStaticLib = v }) - (boolOpt [] []) - - ,option "" ["executable-dynamic"] - "Executable dynamic linking" - configDynExe (\v flags -> flags { configDynExe = v }) - (boolOpt [] []) - - ,option "" ["executable-static"] - "Executable fully static linking" - configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v }) - (boolOpt [] []) - - ,option "" ["profiling"] - "Executable and library profiling" - configProf (\v flags -> flags { configProf = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling (DEPRECATED)" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - - ,option "" ["profiling-detail"] - ("Profiling detail level for executable and library (default, " ++ - "none, exported-functions, toplevel-functions, all-functions).") - configProfDetail (\v flags -> flags { configProfDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,option "" ["library-profiling-detail"] - "Profiling detail level for libraries only." - configProfLibDetail (\v flags -> flags { configProfLibDetail = v }) - (reqArg' "level" (Flag . flagToProfDetailLevel) - showProfDetailLevelFlag) - - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,multiOption "debug-info" - configDebugInfo (\v flags -> flags { configDebugInfo = v }) - [optArg' "n" (Flag . flagToDebugInfoLevel) - (\f -> case f of - Flag NoDebugInfo -> [] - Flag MinimalDebugInfo -> [Just "1"] - Flag NormalDebugInfo -> [Nothing] - Flag MaximalDebugInfo -> [Just "3"] - _ -> []) - "" ["enable-debug-info"] - "Emit debug info (n is 0--3, default is 0)", - noArg (Flag NoDebugInfo) [] - ["disable-debug-info"] - "Don't emit debug info" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-sections"] - "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)" - configSplitSections (\v flags -> flags { configSplitSections = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["library-stripping"] - "strip libraries upon installation to reduce binary sizes" - configStripLibs (\v flags -> flags { configStripLibs = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - ( "Append the given package database to the list of package" - ++ " databases used (to satisfy dependencies and register into)." - ++ " May be a specific file, 'global' or 'user'. The initial list" - ++ " is ['global'], ['global', 'user'], or ['global', $sandbox]," - ++ " depending on context. Use 'clear' to reset the list to empty." - ++ " See the user guide for details.") - configPackageDBs (\v flags -> flags { configPackageDBs = v }) - (reqArg' "DB" readPackageDbList showPackageDbList) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg "FLAGS" - (parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment) - legacyShowFlagAssignment') - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["deterministic"] - "Try to be as deterministic as possible (used by the test suite)" - configDeterministic (\v flags -> flags {configDeterministic = v}) - (boolOpt [] []) - - ,option "" ["ipid"] - "Installed package ID to compile this package as" - configIPID (\v flags -> flags {configIPID = v}) - (reqArgFlag "IPID") - - ,option "" ["cid"] - "Installed component ID to compile this component as" - (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v}) - (reqArgFlag "CID") - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-framework-dirs"] - "A list of directories to search for external frameworks (OS X only)" - configExtraFrameworkDirs - (\v flags -> flags {configExtraFrameworkDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-prog-path"] - "A list of directories to search for required programs (in addition to the normal search locations)" - configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v}) - (reqArg' "PATH" (\x -> toNubList [x]) fromNubList) - - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec)) - (map prettyShow)) - - ,option "" ["dependency"] - "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\"" - configDependencies (\v flags -> flags { configDependencies = v}) - (reqArg "NAME[:COMPONENT_NAME]=CID" - (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent)) - (map (\(GivenComponent pn cn cid) -> - prettyShow pn - ++ case cn of LMainLibName -> "" - LSubLibName n -> ":" ++ prettyShow n - ++ "=" ++ prettyShow cid))) - - ,option "" ["instantiate-with"] - "A mapping of signature names to concrete module instantiations." - configInstantiateWith (\v flags -> flags { configInstantiateWith = v }) - (reqArg "NAME=MOD" - (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry)) - (map (Disp.renderStyle defaultStyle . dispModSubstEntry))) - - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - - ,option "" ["coverage"] - "build package with Haskell Program Coverage. (GHC only)" - configCoverage (\v flags -> flags { configCoverage = v }) - (boolOpt [] []) - - ,option "" ["library-coverage"] - "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)" - configLibCoverage (\v flags -> flags { configLibCoverage = v }) - (boolOpt [] []) - - ,option "" ["exact-configuration"] - "All direct dependencies and flags are provided on the command line." - configExactConfiguration - (\v flags -> flags { configExactConfiguration = v }) - trueArg - - ,option "" ["benchmarks"] - "dependency checking and compilation for benchmarks listed in the package description file." - configBenchmarks (\v flags -> flags { configBenchmarks = v }) - (boolOpt [] []) - - ,option "" ["relocatable"] - "building a package that is relocatable. (GHC only)" - configRelocatable (\v flags -> flags { configRelocatable = v}) - (boolOpt [] []) - - ,option "" ["response-files"] - "enable workaround for old versions of programs like \"ar\" that do not support @file arguments" - configUseResponseFiles - (\v flags -> flags { configUseResponseFiles = v }) - (boolOpt' ([], ["disable-response-files"]) ([], [])) - - ,option "" ["allow-depending-on-private-libs"] - ( "Allow depending on private libraries. " - ++ "If set, the library visibility check MUST be done externally." ) - configAllowDependingOnPrivateLibs - (\v flags -> flags { configAllowDependingOnPrivateLibs = v }) - trueArg - ] - where - liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - - reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -readPackageDbList :: String -> [Maybe PackageDB] -readPackageDbList "clear" = [Nothing] -readPackageDbList "global" = [Just GlobalPackageDB] -readPackageDbList "user" = [Just UserPackageDB] -readPackageDbList other = [Just (SpecificPackageDB other)] - -showPackageDbList :: [Maybe PackageDB] -> [String] -showPackageDbList = map showPackageDb - where - showPackageDb Nothing = "clear" - showPackageDb (Just GlobalPackageDB) = "global" - showPackageDb (Just UserPackageDB) = "user" - showPackageDb (Just (SpecificPackageDB db)) = db - -showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String] -showProfDetailLevelFlag NoFlag = [] -showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl] - -parsecGivenComponent :: ParsecParser GivenComponent -parsecGivenComponent = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - ucn <- parsec - return $ if unUnqualComponentName ucn == unPackageName pn - then LMainLibName - else LSubLibName ucn - _ <- P.char '=' - cid <- parsec - return $ GivenComponent pn ln cid - -installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] -installDirsOptions = - [ option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - , option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - , option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - , option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - , option "" ["dynlibdir"] - "installation directory for dynamic libraries" - dynlibdir (\v flags -> flags { dynlibdir = v }) - installDirArg - - , option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - , option "" ["libexecsubdir"] - "subdirectory of libexecdir in which private executables are installed" - libexecsubdir (\v flags -> flags { libexecsubdir = v }) - installDirArg - - , option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - , option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - , option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - , option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - , option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - - , option "" ["sysconfdir"] - "installation directory for configuration files" - sysconfdir (\v flags -> flags { sysconfdir = v }) - installDirArg - ] - where - installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ConfigFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity, - -- This is the same hack as in 'buildArgs'. But I (ezyang) don't - -- think it's a hack, it's the right way to make hooks more robust - -- TODO: Stop using this eventually when 'UserHooks' gets changed - copyArgs :: [String], - copyCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = NoFlag, - copyVerbosity = Flag normal, - copyArgs = [], - copyCabalFilePath = mempty - } - -copyCommand :: CommandUI CopyFlags -copyCommand = CommandUI - { commandName = "copy" - , commandSynopsis = "Copy the files of all/specific components to install locations." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables and libraries. " - ++ "Does not call register, and allows a prefix at install time. " - ++ "Without the --destdir flag, configure determines location.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " copy " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " copy foo " - ++ " A component (i.e. lib, exe, test suite)" - , commandUsage = usageAlternatives "copy" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultCopyFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ copyOptions ShowArgs - ParseArgs -> copyOptions ParseArgs -} - -copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags] -copyOptions showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> case copyDest flags of - Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'." - _ -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - - ,option "" ["target-package-db"] - "package database to copy files into. Required when using ${pkgroot} prefix." - copyDest (\v flags -> case copyDest flags of - NoFlag -> flags { copyDest = v } - Flag NoCopyDest -> flags { copyDest = v } - _ -> error "Use either 'destdir' or 'target-package-db'.") - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CopyFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDest :: Flag CopyDest, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity, - -- this is only here, because we can not - -- change the hooks API. - installCabalFilePath :: Flag FilePath - } - deriving (Show, Generic) - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDest = Flag NoCopyDest, - installDistPref = NoFlag, - installUseWrapper = Flag False, - installInPlace = Flag False, - installVerbosity = Flag normal, - installCabalFilePath = mempty - } - -installCommand :: CommandUI InstallFlags -installCommand = CommandUI - { commandName = "install" - , commandSynopsis = - "Copy the files into the install locations. Run register." - , commandDescription = Just $ \_ -> wrapText $ - "Unlike the copy command, install calls the register command." - ++ "If you want to install into a location that is not what was" - ++ "specified in the configure step, use the copy command.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " install [FLAGS]\n" - , commandDefaultFlags = defaultInstallFlags - , commandOptions = \showOrParseArgs -> case showOrParseArgs of - ShowArgs -> filter ((`notElem` ["target-package-db"]) - . optionName) $ installOptions ShowArgs - ParseArgs -> installOptions ParseArgs - } - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ,option "" ["target-package-db"] - "package database to install into. Required when using ${pkgroot} prefix." - installDest (\v flags -> flags { installDest = v }) - (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb)) - (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup InstallFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDirectory :: Flag FilePath, - sDistDistPref :: Flag FilePath, - sDistListSources :: Flag FilePath, - sDistVerbosity :: Flag Verbosity - } - deriving (Show, Generic, Typeable) - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDirectory = mempty, - sDistDistPref = NoFlag, - sDistListSources = mempty, - sDistVerbosity = Flag normal - } - -sdistCommand :: CommandUI SDistFlags -sdistCommand = CommandUI - { commandName = "sdist" - , commandSynopsis = - "Generate a source distribution file (.tar.gz)." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " sdist [FLAGS]\n" - , commandDefaultFlags = defaultSDistFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["list-sources"] - "Just write a list of the package's sources to a file" - sDistListSources (\v flags -> flags { sDistListSources = v }) - (reqArgFlag "FILE") - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - - ,option "" ["output-directory"] - ("Generate a source distribution in the given directory, " - ++ "without creating a tarball") - sDistDirectory (\v flags -> flags { sDistDirectory = v }) - (reqArgFlag "DIR") - ] - } - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup SDistFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regPrintId :: Flag Bool, - regVerbosity :: Flag Verbosity, - -- Same as in 'buildArgs' and 'copyArgs' - regArgs :: [String], - regCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = NoFlag, - regPrintId = Flag False, - regArgs = [], - regCabalFilePath = mempty, - regVerbosity = Flag normal - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = CommandUI - { commandName = "register" - , commandSynopsis = - "Register this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " register [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file/directory" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - - ,option "" ["print-ipid"] - "print the installed package ID calculated for this package" - regPrintId (\v flags -> flags { regPrintId = v }) - trueArg - ] - } - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = CommandUI - { commandName = "unregister" - , commandSynopsis = - "Unregister this package with the compiler." - , commandDescription = Nothing - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " unregister [FLAGS]\n" - , commandDefaultFlags = defaultRegisterFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - } - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup RegisterFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourTestSuites :: Flag Bool, - hscolourBenchmarks :: Flag Bool, - hscolourForeignLibs :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity, - hscolourCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourTestSuites = Flag False, - hscolourBenchmarks = Flag False, - hscolourDistPref = NoFlag, - hscolourForeignLibs = Flag False, - hscolourVerbosity = Flag normal, - hscolourCabalFilePath = mempty - } - -instance Monoid HscolourFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HscolourFlags where - (<>) = gmappend - -hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = CommandUI - { commandName = "hscolour" - , commandSynopsis = - "Generate HsColour colourised code, in HTML format." - , commandDescription = Just (\_ -> "Requires the hscolour program.\n") - , commandNotes = Just $ \_ -> - "Deprecated in favour of 'cabal haddock --hyperlink-source'." - , commandUsage = \pname -> - "Usage: " ++ pname ++ " hscolour [FLAGS]\n" - , commandDefaultFlags = defaultHscolourFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity hscolourVerbosity - (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run hscolour for Test Suite targets" - hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run hscolour for Benchmark targets" - hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run hscolour for Foreign Library targets" - hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run hscolour for all targets" - (\f -> allFlags [ hscolourExecutables f - , hscolourTestSuites f - , hscolourBenchmarks f - , hscolourForeignLibs f - ]) - (\v flags -> flags { hscolourExecutables = v - , hscolourTestSuites = v - , hscolourBenchmarks = v - , hscolourForeignLibs = v - }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - } - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - - --- | When we build haddock documentation, there are two cases: --- --- 1. We build haddocks only for the current development version, --- intended for local use and not for distribution. In this case, --- we store the generated documentation in @/doc/html/@. --- --- 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 @/doc/html/-docs@. -data HaddockTarget = ForHackage | ForDevelopment deriving (Eq, Show, Generic, Typeable) - -instance Binary HaddockTarget -instance Structured HaddockTarget - -instance Pretty HaddockTarget where - pretty ForHackage = Disp.text "for-hackage" - pretty ForDevelopment = Disp.text "for-development" - -instance Parsec HaddockTarget where - parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage - , P.string "for-development" >> return ForDevelopment] - -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockForHackage :: Flag HaddockTarget, - haddockExecutables :: Flag Bool, - haddockTestSuites :: Flag Bool, - haddockBenchmarks :: Flag Bool, - haddockForeignLibs :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockLinkedSource :: Flag Bool, - haddockQuickJump :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockContents :: Flag PathTemplate, - haddockDistPref :: Flag FilePath, - haddockKeepTempFiles:: Flag Bool, - haddockVerbosity :: Flag Verbosity, - haddockCabalFilePath :: Flag FilePath, - haddockArgs :: [String] - } - deriving (Show, Generic, Typeable) - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockForHackage = NoFlag, - haddockExecutables = Flag False, - haddockTestSuites = Flag False, - haddockBenchmarks = Flag False, - haddockForeignLibs = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockLinkedSource = Flag False, - haddockQuickJump = Flag False, - haddockHscolourCss = NoFlag, - haddockContents = NoFlag, - haddockDistPref = NoFlag, - haddockKeepTempFiles= Flag False, - haddockVerbosity = Flag normal, - haddockCabalFilePath = mempty, - haddockArgs = mempty - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = CommandUI - { commandName = "haddock" - , commandSynopsis = "Generate Haddock HTML documentation." - , commandDescription = Just $ \_ -> - "Requires the program haddock, version 2.x.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "haddock" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultHaddockFlags - , commandOptions = \showOrParseArgs -> - haddockOptions showOrParseArgs - ++ programDbPaths progDb ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programDbOption progDb showOrParseArgs - haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v }) - ++ programDbOptions progDb ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - } - where - progDb = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramDb - -haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] -haddockOptions showOrParseArgs = - [optionVerbosity haddockVerbosity - (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref - haddockDistPref (\d flags -> flags { haddockDistPref = d }) - showOrParseArgs - - ,option "" ["keep-temp-files"] - "Keep temporary files" - haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b }) - trueArg - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["for-hackage"] - "Collection of flags to generate documentation suitable for upload to hackage" - haddockForHackage (\v flags -> flags { haddockForHackage = v }) - (noArg (Flag ForHackage)) - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["tests"] - "Run haddock for Test Suite targets" - haddockTestSuites (\v flags -> flags { haddockTestSuites = v }) - trueArg - - ,option "" ["benchmarks"] - "Run haddock for Benchmark targets" - haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v }) - trueArg - - ,option "" ["foreign-libraries"] - "Run haddock for Foreign Library targets" - haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v }) - trueArg - - ,option "" ["all"] - "Run haddock for all targets" - (\f -> allFlags [ haddockExecutables f - , haddockTestSuites f - , haddockBenchmarks f - , haddockForeignLibs f - ]) - (\v flags -> flags { haddockExecutables = v - , haddockTestSuites = v - , haddockBenchmarks = v - , haddockForeignLibs = v - }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"] - "Hyperlink the documentation to the source code" - haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v }) - trueArg - - ,option "" ["quickjump"] - "Generate an index for interactive documentation navigation" - haddockQuickJump (\v flags -> flags { haddockQuickJump = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - - ,option "" ["contents-location"] - "Bake URL in as the location for the contents page" - haddockContents (\v flags -> flags { haddockContents = v }) - (reqArg' "URL" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - ] - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup HaddockFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity, - cleanCabalFilePath :: Flag FilePath - } - deriving (Show, Generic, Typeable) - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = NoFlag, - cleanVerbosity = Flag normal, - cleanCabalFilePath = mempty - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = CommandUI - { commandName = "clean" - , commandSynopsis = "Clean up after a build." - , commandDescription = Just $ \_ -> - "Removes .hi, .o, preprocessed sources, etc.\n" - , commandNotes = Nothing - , commandUsage = \pname -> - "Usage: " ++ pname ++ " clean [FLAGS]\n" - , commandDefaultFlags = defaultCleanFlags - , commandOptions = \showOrParseArgs -> - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - } - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup CleanFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity, - buildNumJobs :: Flag (Maybe Int), - -- TODO: this one should not be here, it's just that the silly - -- UserHooks stop us from passing extra info in other ways - buildArgs :: [String], - buildCabalFilePath :: Flag FilePath - } - deriving (Read, Show, Generic, Typeable) - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = mempty, - buildVerbosity = Flag normal, - buildNumJobs = mempty, - buildArgs = [], - buildCabalFilePath = mempty - } - -buildCommand :: ProgramDb -> CommandUI BuildFlags -buildCommand progDb = CommandUI - { commandName = "build" - , commandSynopsis = "Compile all/specific components." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " build " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " build foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " build Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " build Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " build foo:Foo.Bar\n" --- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "build" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBuildFlags - , commandOptions = \showOrParseArgs -> - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - ++ buildOptions progDb showOrParseArgs - } - -buildOptions :: ProgramDb -> ShowOrParseArgs - -> [OptionField BuildFlags] -buildOptions progDb showOrParseArgs = - [ optionNumJobs - buildNumJobs (\v flags -> flags { buildNumJobs = v }) - ] - - ++ programDbPaths progDb showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - buildProgramArgs (\v fs -> fs { buildProgramArgs = v }) - - ++ programDbOptions progDb showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BuildFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * REPL Flags --- ------------------------------------------------------------ - -data ReplFlags = ReplFlags { - replProgramPaths :: [(String, FilePath)], - replProgramArgs :: [(String, [String])], - replDistPref :: Flag FilePath, - replVerbosity :: Flag Verbosity, - replReload :: Flag Bool, - replReplOptions :: [String] - } - deriving (Show, Generic, Typeable) - -defaultReplFlags :: ReplFlags -defaultReplFlags = ReplFlags { - replProgramPaths = mempty, - replProgramArgs = [], - replDistPref = NoFlag, - replVerbosity = Flag normal, - replReload = Flag False, - replReplOptions = [] - } - -instance Monoid ReplFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup ReplFlags where - (<>) = gmappend - -replCommand :: ProgramDb -> CommandUI ReplFlags -replCommand progDb = CommandUI - { commandName = "repl" - , commandSynopsis = - "Open an interpreter session for the given component." - , commandDescription = Just $ \pname -> wrapText $ - "If the current directory contains no package, ignores COMPONENT " - ++ "parameters and opens an interactive interpreter session; if a " - ++ "sandbox is present, its package database will be used.\n" - ++ "\n" - ++ "Otherwise, (re)configures with the given or default flags, and " - ++ "loads the interpreter with the relevant modules. For executables, " - ++ "tests and benchmarks, loads the main module (and its " - ++ "dependencies); for libraries all exposed/other modules.\n" - ++ "\n" - ++ "The default component is the library itself, or the executable " - ++ "if that is the only component.\n" - ++ "\n" - ++ "Support for loading specific modules is planned but not " - ++ "implemented yet. For certain scenarios, `" ++ pname - ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will " - ++ "not (re)configure and you will have to specify the location of " - ++ "other modules, if required.\n" - - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " repl " - ++ " The first component in the package\n" - ++ " " ++ pname ++ " repl foo " - ++ " A named component (i.e. lib, exe, test suite)\n" - ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\"" - ++ " Specifying flags for interpreter\n" ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " repl Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " repl Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " repl foo:Foo.Bar\n" --- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n" - , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n" - , commandDefaultFlags = defaultReplFlags - , commandOptions = \showOrParseArgs -> - optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v }) - : optionDistPref - replDistPref (\d flags -> flags { replDistPref = d }) - showOrParseArgs - - : programDbPaths progDb showOrParseArgs - replProgramPaths (\v flags -> flags { replProgramPaths = v}) - - ++ programDbOption progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ programDbOptions progDb showOrParseArgs - replProgramArgs (\v flags -> flags { replProgramArgs = v}) - - ++ case showOrParseArgs of - ParseArgs -> - [ option "" ["reload"] - "Used from within an interpreter to update files." - replReload (\v flags -> flags { replReload = v }) - trueArg - ] - _ -> [] - ++ map liftReplOption (replOptions showOrParseArgs) - } - where - liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v }) - -replOptions :: ShowOrParseArgs -> [OptionField [String]] -replOptions _ = [ option [] ["repl-options"] "use this option for the repl" id - const (reqArg "FLAG" (succeedReadE (:[])) id) ] - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestShowDetails = Never | Failures | Always | Streaming | Direct - deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable) - -instance Binary TestShowDetails -instance Structured TestShowDetails - -knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] - -instance Pretty TestShowDetails where - pretty = Disp.text . lowercase . show - -instance Parsec TestShowDetails where - parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident - where - ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (prettyShow x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? -instance Monoid TestShowDetails where - mempty = Never - mappend = (<>) - -instance Semigroup TestShowDetails where - a <> b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - testMachineLog :: Flag PathTemplate, - testShowDetails :: Flag TestShowDetails, - testKeepTix :: Flag Bool, - testWrapper :: Flag FilePath, - testFailWhenNoTestSuites :: Flag Bool, - -- TODO: think about if/how options are passed to test exes - testOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = NoFlag, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Failures, - testKeepTix = toFlag False, - testWrapper = NoFlag, - testFailWhenNoTestSuites = toFlag False, - testOptions = [] - } - -testCommand :: CommandUI TestFlags -testCommand = CommandUI - { commandName = "test" - , commandSynopsis = - "Run all/specific tests in the test suite." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-tests` flag and builds" - ++ " the test suite.\n" - ++ "\n" - ++ "Remember that the tests' dependencies must be installed if there" - ++ " are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-tests`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running tests.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "test" - [ "[FLAGS]" - , "TESTCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultTestFlags - , commandOptions = testOptions' - } - -testOptions' :: ShowOrParseArgs -> [OptionField TestFlags] -testOptions' showOrParseArgs = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["show-details"] - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases. " - ++ "'streaming': show results of test cases in real time." - ++ "'direct': send results of test cases in real time; no log file.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (parsecToReadE (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map prettyShow knownTestShowDetails)) - (fmap toFlag parsec)) - (flagToList . fmap prettyShow)) - , option [] ["keep-tix-files"] - "keep .tix files for HPC between test runs" - testKeepTix (\v flags -> flags { testKeepTix = v}) - trueArg - , option [] ["test-wrapper"] - "Run test through a wrapper." - testWrapper (\v flags -> flags { testWrapper = v }) - (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath) - (flagToList :: Flag FilePath -> [FilePath])) - , option [] ["fail-when-no-test-suites"] - ("Exit with failure when no test suites are found.") - testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v}) - trueArg - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup TestFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Benchmark flags --- ------------------------------------------------------------ - -data BenchmarkFlags = BenchmarkFlags { - benchmarkDistPref :: Flag FilePath, - benchmarkVerbosity :: Flag Verbosity, - benchmarkOptions :: [PathTemplate] - } deriving (Show, Generic, Typeable) - -defaultBenchmarkFlags :: BenchmarkFlags -defaultBenchmarkFlags = BenchmarkFlags { - benchmarkDistPref = NoFlag, - benchmarkVerbosity = Flag normal, - benchmarkOptions = [] - } - -benchmarkCommand :: CommandUI BenchmarkFlags -benchmarkCommand = CommandUI - { commandName = "bench" - , commandSynopsis = - "Run all/specific benchmarks." - , commandDescription = Just $ \pname -> wrapText $ - "If necessary (re)configures with `--enable-benchmarks` flag and" - ++ " builds the benchmarks.\n" - ++ "\n" - ++ "Remember that the benchmarks' dependencies must be installed if" - ++ " there are additional ones; e.g. with `" ++ pname - ++ " install --only-dependencies --enable-benchmarks`.\n" - ++ "\n" - ++ "By defining UserHooks in a custom Setup.hs, the package can" - ++ " define actions to be executed before and after running" - ++ " benchmarks.\n" - , commandNotes = Nothing - , commandUsage = usageAlternatives "bench" - [ "[FLAGS]" - , "BENCHCOMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultBenchmarkFlags - , commandOptions = benchmarkOptions' - } - -benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags] -benchmarkOptions' showOrParseArgs = - [ optionVerbosity benchmarkVerbosity - (\v flags -> flags { benchmarkVerbosity = v }) - , optionDistPref - benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d }) - showOrParseArgs - , option [] ["benchmark-options"] - ("give extra options to benchmark executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs) - (const [])) - , option [] ["benchmark-option"] - ("give extra option to benchmark executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $benchmark)") - benchmarkOptions (\v flags -> flags { benchmarkOptions = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) - (map fromPathTemplate)) - ] - -emptyBenchmarkFlags :: BenchmarkFlags -emptyBenchmarkFlags = mempty - -instance Monoid BenchmarkFlags where - mempty = gmempty - mappend = (<>) - -instance Semigroup BenchmarkFlags where - (<>) = gmappend - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramDb -> String -programFlagsDescription progDb = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progDb ] - ++ "\n" - --- | For each known program @PROG@ in 'progDb', produce a @with-PROG@ --- 'OptionField'. -programDbPaths - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths progDb showOrParseArgs get set = - programDbPaths' ("with-" ++) progDb showOrParseArgs get set - --- | Like 'programDbPaths', but allows to customise the option name. -programDbPaths' - :: (String -> String) - -> ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programDbPaths' mkName progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) - (knownPrograms progDb) - where - withProgramPath prog = - option "" [mkName prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - --- | For each known program @PROG@ in 'progDb', produce a @PROG-option@ --- 'OptionField'. -programDbOption - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOption progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOption "PROG"] - ParseArgs -> map (programOption . programName . fst) - (knownPrograms progDb) - where - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args - | (prog', args) <- progArgs, prog==prog' ])) - - --- | For each known program @PROG@ in 'progDb', produce a @PROG-options@ --- 'OptionField'. -programDbOptions - :: ProgramDb - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programDbOptions progDb showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG"] - ParseArgs -> map (programOptions . programName . fst) - (knownPrograms progDb) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags - -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt' = Command.boolOpt' flagToMaybe Flag - -trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT -falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags -optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - where - distPrefFlagName ShowArgs = ["builddir"] - distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - -optionNumJobs :: (flags -> Flag (Maybe Int)) - -> (Flag (Maybe Int) -> flags -> flags) - -> OptionField flags -optionNumJobs get set = - option "j" ["jobs"] - "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)." - get set - (optArg "NUM" (fmap Flag numJobsParser) - (Flag Nothing) - (map (Just . maybe "$ncpus" show) . flagToList)) - where - numJobsParser :: ReadE (Maybe Int) - numJobsParser = ReadE $ \s -> - case s of - "$ncpus" -> Right Nothing - _ -> case reads s of - [(n, "")] - | n < 1 -> Left "The number of jobs should be 1 or more." - | otherwise -> Right (Just n) - _ -> Left "The jobs value should be a number or '$ncpus'" - - --- ------------------------------------------------------------ --- * show-build-info command flags --- ------------------------------------------------------------ - -data ShowBuildInfoFlags = ShowBuildInfoFlags - { buildInfoBuildFlags :: BuildFlags - , buildInfoOutputFile :: Maybe FilePath - } deriving (Show, Typeable) - -defaultShowBuildFlags :: ShowBuildInfoFlags -defaultShowBuildFlags = - ShowBuildInfoFlags - { buildInfoBuildFlags = defaultBuildFlags - , buildInfoOutputFile = Nothing - } - -showBuildInfoCommand :: ProgramDb -> CommandUI ShowBuildInfoFlags -showBuildInfoCommand progDb = CommandUI - { commandName = "show-build-info" - , commandSynopsis = "Emit details about how a package would be built." - , commandDescription = Just $ \_ -> wrapText $ - "Components encompass executables, tests, and benchmarks.\n" - ++ "\n" - ++ "Affected by configuration options, see `configure`.\n" - , commandNotes = Just $ \pname -> - "Examples:\n" - ++ " " ++ pname ++ " show-build-info " - ++ " All the components in the package\n" - ++ " " ++ pname ++ " show-build-info foo " - ++ " A component (i.e. lib, exe, test suite)\n\n" - ++ programFlagsDescription progDb ---TODO: re-enable once we have support for module/file targets --- ++ " " ++ pname ++ " show-build-info Foo.Bar " --- ++ " A module\n" --- ++ " " ++ pname ++ " show-build-info Foo/Bar.hs" --- ++ " A file\n\n" --- ++ "If a target is ambiguous it can be qualified with the component " --- ++ "name, e.g.\n" --- ++ " " ++ pname ++ " show-build-info foo:Foo.Bar\n" --- ++ " " ++ pname ++ " show-build-info testsuite1:Foo/Bar.hs\n" - , commandUsage = usageAlternatives "show-build-info" $ - [ "[FLAGS]" - , "COMPONENTS [FLAGS]" - ] - , commandDefaultFlags = defaultShowBuildFlags - , commandOptions = \showOrParseArgs -> - parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb - ++ - [ option [] ["buildinfo-json-output"] - "Write the result to the given file instead of stdout" - buildInfoOutputFile (\pf flags -> flags { buildInfoOutputFile = pf }) - (reqArg' "FILE" Just (maybe [] pure)) - ] - - } - -parseBuildFlagsForShowBuildInfoFlags :: ShowOrParseArgs -> ProgramDb -> [OptionField ShowBuildInfoFlags] -parseBuildFlagsForShowBuildInfoFlags showOrParseArgs progDb = - map - (liftOption - buildInfoBuildFlags - (\bf flags -> flags { buildInfoBuildFlags = bf } ) - ) - buildFlags - where - buildFlags = buildOptions progDb showOrParseArgs - ++ - [ optionVerbosity - buildVerbosity (\v flags -> flags { buildVerbosity = v }) - - , optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs - ] - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ optFlag' "sysconfdir" sysconfdir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - -configureCCompiler :: Verbosity -> ProgramDb - -> IO (FilePath, [String]) -configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram - -configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String]) -configureLinker verbosity progdb = configureProg verbosity progdb ldProgram - -configureProg :: Verbosity -> ProgramDb -> Program - -> IO (FilePath, [String]) -configureProg verbosity programDb prog = do - (p, _) <- requireProgram verbosity prog programDb - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz" --- > = ["--foo=C:/Program Files/Bar", "--baz"] --- --- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz" --- > = ["-DMSGSTR=\"foo bar\"","--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ('\\':'"':s) = string ('"':w) s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = --- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] --- in [TestLabel "very basic option parsing" $ TestList [ --- "getOpt flags" ~: "failed" ~: --- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, --- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] --- ~=? flags, --- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', --- "getOpt unknown opts" ~: "failed" ~: --- ["--unknown1", "--unknown2"] ~=? unkFlags, --- "getOpt errors" ~: "failed" ~: [] ~=? ers], --- --- TestLabel "test location of various compilers" $ TestList --- ["configure parsing for prefix and compiler flag" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) --- | (name, comp) <- m], --- --- TestLabel "find the package tool" $ TestList --- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, --- "--with-compiler=/foo/comp", "configure"]) --- | (name, comp) <- m], --- --- TestLabel "simpler commands" $ TestList --- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) --- | (flag, flagCmd) <- [("build", BuildCmd), --- ("install", InstallCmd Nothing False), --- ("sdist", SDistCmd), --- ("register", RegisterCmd False)] --- ] --- ] - -{- Testing ideas: - * IO to look for hugs and hugs-pkg (which hugs, etc) - * quickCheck to test permutations of arguments - * what other options can we over-ride with a command-line flag? --} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- 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 diff --git a/src/Distribution/Simple/Setup/Benchmark.hs b/src/Distribution/Simple/Setup/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Benchmark.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Build.hs b/src/Distribution/Simple/Setup/Build.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Build.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Clean.hs b/src/Distribution/Simple/Setup/Clean.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Clean.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Common.hs b/src/Distribution/Simple/Setup/Common.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Common.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Config.hs b/src/Distribution/Simple/Setup/Config.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Config.hs @@ -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 + ) diff --git a/src/Distribution/Simple/Setup/Copy.hs b/src/Distribution/Simple/Setup/Copy.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Copy.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Global.hs b/src/Distribution/Simple/Setup/Global.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Global.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Haddock.hs b/src/Distribution/Simple/Setup/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Haddock.hs @@ -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 @/doc/html/@. +-- +-- 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 @/doc/html/-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 diff --git a/src/Distribution/Simple/Setup/Hscolour.hs b/src/Distribution/Simple/Setup/Hscolour.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Hscolour.hs @@ -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") + ] + } diff --git a/src/Distribution/Simple/Setup/Install.hs b/src/Distribution/Simple/Setup/Install.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Install.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Register.hs b/src/Distribution/Simple/Setup/Register.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Register.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Repl.hs b/src/Distribution/Simple/Setup/Repl.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Repl.hs @@ -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") + ] diff --git a/src/Distribution/Simple/Setup/SDist.hs b/src/Distribution/Simple/Setup/SDist.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/SDist.hs @@ -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 diff --git a/src/Distribution/Simple/Setup/Test.hs b/src/Distribution/Simple/Setup/Test.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/Setup/Test.hs @@ -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 diff --git a/src/Distribution/Simple/SetupHooks/Errors.hs b/src/Distribution/Simple/SetupHooks/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/SetupHooks/Errors.hs @@ -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 ++ "'" diff --git a/src/Distribution/Simple/SetupHooks/Internal.hs b/src/Distribution/Simple/SetupHooks/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/SetupHooks/Internal.hs @@ -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 + +-------------------------------------------------------------------------------- diff --git a/src/Distribution/Simple/SetupHooks/Rule.hs b/src/Distribution/Simple/SetupHooks/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Simple/SetupHooks/Rule.hs @@ -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 diff --git a/src/Distribution/Simple/ShowBuildInfo.hs b/src/Distribution/Simple/ShowBuildInfo.hs --- a/src/Distribution/Simple/ShowBuildInfo.hs +++ b/src/Distribution/Simple/ShowBuildInfo.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + -- | -- This module defines a simple JSON-based format for exporting basic -- information about a Cabal package and the compiler configuration Cabal -- would use to build it. This can be produced with the --- @cabal new-show-build-info@ command. +-- @cabal build --enable-build-info@ command. -- -- -- This format is intended for consumption by external tooling and should @@ -14,7 +17,7 @@ -- Below is an example of the output this module produces, -- -- @ --- { "cabal-version": "1.23.0.0", +-- { "cabal-lib-version": "1.23.0.0", -- "compiler": { -- "flavour": "GHC", -- "compiler-id": "ghc-7.10.2", @@ -34,7 +37,10 @@ -- } -- @ -- --- The @cabal-version@ property provides the version of the Cabal library +-- The output format needs to be validated against 'doc/json-schemas/build-info.schema.json'. +-- If the format changes, update the schema as well! +-- +-- The @cabal-lib-version@ property provides the version of the Cabal library -- which generated the output. The @compiler@ property gives some basic -- information about the compiler Cabal would use to compile the package. -- @@ -52,95 +58,138 @@ -- * @src-files@: any other Haskell sources needed by the component -- -- Note: At the moment this is only supported when using the GHC compiler. --- +module Distribution.Simple.ShowBuildInfo + ( mkBuildInfo + , mkBuildInfo' + , mkCompilerInfo + , mkComponentInfo + ) where -module Distribution.Simple.ShowBuildInfo (mkBuildInfo) where +import System.FilePath import Distribution.Compat.Prelude import Prelude () -import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Program.GHC as GHC -import Distribution.PackageDescription import Distribution.Compiler -import Distribution.Verbosity -import Distribution.Simple.Compiler +import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Build (BuildFlags) import Distribution.Simple.Utils (cabalVersion) -import Distribution.Simple.Utils.Json -import Distribution.Types.TargetInfo import Distribution.Text -import Distribution.Pretty +import Distribution.Types.TargetInfo +import Distribution.Utils.Json import Distribution.Utils.Path +import Distribution.Verbosity -- | Construct a JSON document describing the build information for a -- package. mkBuildInfo - :: PackageDescription -- ^ Mostly information from the .cabal file - -> LocalBuildInfo -- ^ Configuration information - -> BuildFlags -- ^ Flags that the user passed to build + :: AbsolutePath (Dir Pkg) + -- ^ The source directory of the package + -> PackageDescription + -- ^ Mostly information from the .cabal file + -> LocalBuildInfo + -- ^ Configuration information + -> BuildFlags + -- ^ Flags that the user passed to build + -> (ConfiguredProgram, Compiler) + -- ^ Compiler information. + -- Needs to be passed explicitly, as we can't extract that information here + -- without some partial function. -> [TargetInfo] - -> Json -mkBuildInfo pkg_descr lbi _flags targetsToBuild = info + -> ([String], Json) + -- ^ Json representation of buildinfo alongside generated warnings +mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields) where - targetToNameAndLBI target = - (componentLocalName $ targetCLBI target, targetCLBI target) - componentsToBuild = map targetToNameAndLBI targetsToBuild - (.=) :: String -> Json -> (String, Json) - k .= v = (k, v) - - info = JsonObject - [ "cabal-version" .= JsonString (display cabalVersion) - , "compiler" .= mkCompilerInfo - , "components" .= JsonArray (map mkComponentInfo componentsToBuild) - ] + buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos + componentInfosWithWarnings = map (mkComponentInfo wdir pkg_descr lbi . targetCLBI) targetsToBuild + componentInfos = map snd componentInfosWithWarnings + warnings = concatMap fst componentInfosWithWarnings - mkCompilerInfo = JsonObject - [ "flavour" .= JsonString (prettyShow $ compilerFlavor $ compiler lbi) - , "compiler-id" .= JsonString (showCompilerId $ compiler lbi) - , "path" .= path - ] - where - path = maybe JsonNull (JsonString . programPath) - $ (flavorToProgram . compilerFlavor $ compiler lbi) - >>= flip lookupProgram (withPrograms lbi) +-- | A variant of 'mkBuildInfo' if you need to call 'mkCompilerInfo' and +-- 'mkComponentInfo' yourself. +-- +-- If you change the format or any name in the output json, don't forget to update +-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of +-- @--enable-build-info@\/@--disable-build-info@. +mkBuildInfo' + :: Json + -- ^ The 'Json' from 'mkCompilerInfo' + -> [Json] + -- ^ The 'Json' from 'mkComponentInfo' + -> [(String, Json)] +mkBuildInfo' compilerInfo componentInfos = + [ "cabal-lib-version" .= JsonString (display cabalVersion) + , "compiler" .= compilerInfo + , "components" .= JsonArray componentInfos + ] - flavorToProgram :: CompilerFlavor -> Maybe Program - flavorToProgram GHC = Just ghcProgram - flavorToProgram GHCJS = Just ghcjsProgram - flavorToProgram UHC = Just uhcProgram - flavorToProgram JHC = Just jhcProgram - flavorToProgram _ = Nothing +mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json +mkCompilerInfo compilerProgram compilerInfo = + JsonObject + [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo) + , "compiler-id" .= JsonString (showCompilerId compilerInfo) + , "path" .= JsonString (programPath compilerProgram) + ] - mkComponentInfo (name, clbi) = JsonObject - [ "type" .= JsonString compType - , "name" .= JsonString (prettyShow name) - , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) - , "compiler-args" .= JsonArray (map JsonString $ getCompilerArgs bi lbi clbi) - , "modules" .= JsonArray (map (JsonString . display) modules) - , "src-files" .= JsonArray (map JsonString sourceFiles) - , "src-dirs" .= JsonArray (map JsonString $ map getSymbolicPath $ hsSourceDirs bi) +mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json) +mkComponentInfo wdir pkg_descr lbi clbi = + ( warnings + , JsonObject $ + [ "type" .= JsonString compType + , "name" .= JsonString (prettyShow name) + , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi) + , "compiler-args" .= JsonArray (map JsonString compilerArgs) + , "modules" .= JsonArray (map (JsonString . display) modules) + , "src-files" .= JsonArray (map (JsonString . getSymbolicPath) sourceFiles) + , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi) + , "src-dir" .= JsonString (addTrailingPathSeparator (getAbsolutePath wdir)) ] - where - bi = componentBuildInfo comp - comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name - compType = case comp of - CLib _ -> "lib" - CExe _ -> "exe" - CTest _ -> "test" - CBench _ -> "bench" - CFLib _ -> "flib" - modules = case comp of - CLib lib -> explicitLibModules lib - CExe exe -> exeModules exe - _ -> [] - sourceFiles = case comp of - CLib _ -> [] - CExe exe -> [modulePath exe] - _ -> [] + <> cabalFile + ) + where + (warnings, compilerArgs) = getCompilerArgs bi lbi clbi + name = componentLocalName clbi + bi = componentBuildInfo comp + -- If this error happens, a cabal invariant has been violated + comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name + compType = case comp of + CLib _ -> "lib" + CExe _ -> "exe" + CTest _ -> "test" + CBench _ -> "bench" + CFLib _ -> "flib" + modules = case comp of + CLib lib -> explicitLibModules lib + CExe exe -> exeModules exe + CTest test -> + case testInterface test of + TestSuiteExeV10 _ _ -> [] + TestSuiteLibV09 _ modName -> [modName] + TestSuiteUnsupported _ -> [] + CBench bench -> benchmarkModules bench + CFLib flib -> foreignLibModules flib + sourceFiles = case comp of + CLib _ -> [] + CExe exe -> [modulePath exe] + CTest test -> + case testInterface test of + TestSuiteExeV10 _ fp -> [fp] + TestSuiteLibV09 _ _ -> [] + TestSuiteUnsupported _ -> [] + CBench bench -> case benchmarkInterface bench of + BenchmarkExeV10 _ fp -> [fp] + BenchmarkUnsupported _ -> [] + CFLib _ -> [] + cabalFile + | Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString $ getSymbolicPath fp)] + | otherwise = [] -- | Get the command-line arguments that would be passed -- to the compiler to build the given component. @@ -148,15 +197,23 @@ :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo - -> [String] + -> ([String], [String]) getCompilerArgs bi lbi clbi = case compilerFlavor $ compiler lbi of - GHC -> ghc - GHCJS -> ghc - c -> error $ "ShowBuildInfo.getCompilerArgs: Don't know how to get "++ - "build arguments for compiler "++show c + GHC -> ([], ghcArgs) + GHCJS -> ([], ghcArgs) + c -> + ( + [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build " + ++ " arguments for compiler " + ++ show c + ] + , [] + ) where -- This is absolutely awful - ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts - where - baseOpts = GHC.componentGhcOptions normal lbi bi clbi (buildDir lbi) + ghcArgs = + GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts + baseOpts = + GHC.componentGhcOptions normal lbi bi clbi $ + buildDir lbi diff --git a/src/Distribution/Simple/SrcDist.hs b/src/Distribution/Simple/SrcDist.hs --- a/src/Distribution/Simple/SrcDist.hs +++ b/src/Distribution/Simple/SrcDist.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + -- | -- Module : Distribution.Simple.SrcDist -- Copyright : Simon Marlow 2004 @@ -19,89 +24,88 @@ -- The 'createArchive' action uses the external @tar@ program and assumes that -- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. -- The 'sdist' action now also does some distribution QA checks. - --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, +module Distribution.Simple.SrcDist + ( -- * The top level action + sdist - -- ** Snapshots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, + -- ** Parts of 'sdist' + , printPackageProblems + , prepareTree + , createArchive - -- * Extracting the source files - listPackageSources, - listPackageSourcesWithDie, + -- ** Snapshots + , prepareSnapshotTree + , snapshotPackage + , snapshotVersion + , dateToSnapshotNumber - ) where + -- * Extracting the source files + , listPackageSources + , listPackageSourcesWithDie + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () +import Distribution.ModuleName +import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Check hiding (doesFileExist) -import Distribution.Package -import Distribution.ModuleName -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version +import Distribution.Pretty +import Distribution.Simple.BuildPaths import Distribution.Simple.Configure (findDistPrefOrDefault) +import Distribution.Simple.Errors +import Distribution.Simple.Flag import Distribution.Simple.Glob (matchDirFileGlobWithDie) -import Distribution.Simple.Utils -import Distribution.Simple.Setup import Distribution.Simple.PreProcess -import Distribution.Simple.BuildPaths import Distribution.Simple.Program -import Distribution.Pretty -import Distribution.Verbosity +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.SDist +import Distribution.Simple.Utils import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version import qualified Data.Map as Map import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay) -import System.Directory ( doesFileExist ) -import System.IO (IOMode(WriteMode), hPutStrLn, withFile) -import System.FilePath ((), (<.>), dropExtension, isRelative) +import System.Directory (doesFileExist) +import System.IO (IOMode (WriteMode), hPutStrLn, withFile) --- |Create a source distribution. -sdist :: PackageDescription -- ^ information from the tarball - -> SDistFlags -- ^ verbosity & snapshot - -> (FilePath -> FilePath) -- ^ build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () +-- | Create a source distribution. +sdist + :: PackageDescription + -- ^ information from the tarball + -> SDistFlags + -- ^ verbosity & snapshot + -> (FilePath -> FilePath) + -- ^ build prefix (temp dir) + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () sdist pkg flags mkTmpDir pps = do - - distPref <- findDistPrefOrDefault $ sDistDistPref flags - let targetPref = distPref - tmpTargetDir = mkTmpDir distPref + distPref <- findDistPrefOrDefault $ setupDistPref common + let targetPref = i distPref + tmpTargetDir = mkTmpDir (i distPref) -- When given --list-sources, just output the list of sources to a file. case sDistListSources flags of Flag path -> withFile path WriteMode $ \outHandle -> do - ordinary <- listPackageSources verbosity "." pkg pps - traverse_ (hPutStrLn outHandle) ordinary + ordinary <- listPackageSources verbosity mbWorkDir pkg pps + traverse_ (hPutStrLn outHandle . getSymbolicPath) ordinary notice verbosity $ "List of package sources written to file '" ++ path ++ "'" - - NoFlag -> do + NoFlag -> do -- do some QA printPackageProblems verbosity pkg date <- getCurrentTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg + let pkg' + | snapshot = snapshotPackage date pkg + | otherwise = pkg case flagToMaybe (sDistDirectory flags) of Just targetDir -> do generateSourceDir targetDir pkg' info verbosity $ "Source directory created: " ++ targetDir - Nothing -> do createDirectoryIfMissingVerbose verbosity True tmpTargetDir withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do @@ -109,32 +113,37 @@ generateSourceDir targetDir pkg' targzFile <- createArchive verbosity pkg' tmpDir targetPref notice verbosity $ "Source tarball created: " ++ targzFile - where generateSourceDir :: FilePath -> PackageDescription -> IO () generateSourceDir targetDir pkg' = do setupMessage verbosity "Building source dist for" (packageId pkg') - prepareTree verbosity pkg' targetDir pps + prepareTree verbosity mbWorkDir pkg' targetDir pps when snapshot $ overwriteSnapshotPackageDesc verbosity pkg' targetDir - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) + common = sDistCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + mbWorkDir = flagToMaybe $ setupWorkingDir common + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + snapshot = fromFlag (sDistSnapshot flags) -- | List all source files of a package. -- -- Since @Cabal-3.4@ returns a single list. There shouldn't be any -- executable files, they are hardly portable. --- listPackageSources - :: Verbosity -- ^ verbosity - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] listPackageSources verbosity cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity die' cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity dieWithException cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 @@ -144,377 +153,476 @@ -- -- Since @3.4.0.0 listPackageSourcesWithDie - :: Verbosity -- ^ verbosity - -> (Verbosity -> String -> IO [FilePath]) -- ^ 'die'' alternative - -> FilePath -- ^ directory with cabal file - -> PackageDescription -- ^ info from the cabal file - -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes) - -> IO [FilePath] -- ^ relative paths + :: Verbosity + -- ^ verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file + -> PackageDescription + -- ^ info from the cabal file + -> [PPSuffixHandler] + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do - -- Call helpers that actually do all work. - listPackageSources' verbosity rip cwd pkg_descr pps + -- Call helpers that actually do all work. + listPackageSources' verbosity rip cwd pkg_descr pps where pkg_descr = filterAutogenModules pkg_descr0 - listPackageSources' :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -> FilePath + -- ^ verbosity + -> (forall res. Verbosity -> CabalException -> IO [res]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ directory with cabal file -> PackageDescription + -- ^ info from the cabal file -> [PPSuffixHandler] - -> IO [FilePath] -listPackageSources' verbosity rip cwd pkg_descr pps = + -- ^ extra preprocessors (include suffixes) + -> IO [SymbolicPath Pkg File] +listPackageSources' verbosity rip mbWorkDir pkg_descr pps = fmap concat . sequenceA $ - [ - -- Library sources. - fmap concat - . withAllLib $ \Library { - exposedModules = modules, - signatures = sigs, - libBuildInfo = libBi - } -> - allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs) - - -- Executables sources. - , fmap concat - . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps [] - mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath - return (mainSrc:biSrcs) - - -- Foreign library sources - , fmap concat - . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps [] - defFiles <- traverse (findModDefFile verbosity cwd flibBi pps) - (foreignLibModDefFile flib) - return (defFiles ++ biSrcs) - - -- Test suites sources. - , fmap concat - . withAllTest $ \t -> do - let bi = testBuildInfo t - case testInterface t of - TestSuiteExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - TestSuiteLibV09 _ m -> - allSourcesBuildInfo verbosity rip cwd bi pps [m] - TestSuiteUnsupported tp -> - rip verbosity $ "Unsupported test suite type: " ++ show tp - - -- Benchmarks sources. - , fmap concat - . withAllBenchmark $ \bm -> do - let bi = benchmarkBuildInfo bm - case benchmarkInterface bm of - BenchmarkExeV10 _ mainPath -> do - biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps [] - srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath - return (srcMainFile:biSrcs) - BenchmarkUnsupported tp -> - rip verbosity $ "Unsupported benchmark type: " ++ show tp - - -- Data files. - , fmap concat - . for (dataFiles pkg_descr) $ \filename -> do - let srcDataDirRaw = dataDir pkg_descr - srcDataDir | null srcDataDirRaw = "." - | otherwise = srcDataDirRaw - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir filename) - - -- Extra source files. - , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath - - -- Extra doc files. - , fmap concat - . for (extraDocFiles pkg_descr) $ \ filename -> - matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename - - -- License file(s). - , return (map getSymbolicPath $ licenseFiles pkg_descr) - - -- Install-include files, without autogen-include files - , fmap concat - . withAllLib $ \ l -> do - let lbi = libBuildInfo l - incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi) - relincdirs = "." : filter isRelative (includeDirs lbi) - traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls - - -- Setup script, if it exists. - , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd - - -- The .cabal file itself. - , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".") - - ] + [ -- Library sources. + fmap concat + . withAllLib + $ \Library + { exposedModules = modules + , signatures = sigs + , libBuildInfo = libBi + } -> + allSourcesBuildInfo verbosity rip mbWorkDir libBi pps (modules ++ sigs) + , -- Executables sources. + fmap concat + . withAllExe + $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir exeBi pps [] + mainSrc <- findMainExeFile verbosity mbWorkDir exeBi pps mainPath + return (mainSrc : biSrcs) + , -- Foreign library sources + fmap concat + . withAllFLib + $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir flibBi pps [] + defFiles <- + traverse + (findModDefFile verbosity mbWorkDir flibBi pps) + (foreignLibModDefFile flib) + return (defFiles ++ biSrcs) + , -- Test suites sources. + fmap concat + . withAllTest + $ \t -> do + let bi = testBuildInfo t + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps [] + srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath + return (srcMainFile : biSrcs) + TestSuiteLibV09 _ m -> + allSourcesBuildInfo verbosity rip mbWorkDir bi pps [m] + TestSuiteUnsupported tp -> + rip verbosity $ UnsupportedTestSuite (show tp) + , -- Benchmarks sources. + fmap concat + . withAllBenchmark + $ \bm -> do + let bi = benchmarkBuildInfo bm + case benchmarkInterface bm of + BenchmarkExeV10 _ mainPath -> do + biSrcs <- allSourcesBuildInfo verbosity rip mbWorkDir bi pps [] + srcMainFile <- findMainExeFile verbosity mbWorkDir bi pps mainPath + return (srcMainFile : biSrcs) + BenchmarkUnsupported tp -> + rip verbosity $ UnsupportedBenchMark (show tp) + , -- Data files. + fmap concat + . for (dataFiles pkg_descr) + $ \filename -> + do + let srcDataDirRaw = dataDir pkg_descr + srcDataFile :: SymbolicPath Pkg File + srcDataFile + | null (getSymbolicPath srcDataDirRaw) = sameDirectory filename + | otherwise = srcDataDirRaw filename + fmap coerceSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir srcDataFile + , -- Extra source files. + fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> + fmap relativeSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath + , -- Extra doc files. + fmap concat + . for (extraDocFiles pkg_descr) + $ \filename -> + fmap (coerceSymbolicPath . relativeSymbolicPath) + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir filename + , -- Extra files. + fmap concat . for (extraFiles pkg_descr) $ \fpath -> + fmap relativeSymbolicPath + <$> matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) mbWorkDir fpath + , -- License file(s). + return (map (relativeSymbolicPath . coerceSymbolicPath) $ licenseFiles pkg_descr) + , -- Install-include files, without autogen-include files + fmap concat + . withAllLib + $ \l -> do + let lbi = libBuildInfo l + incls = fmap getSymbolicPath $ filter (`notElem` autogenIncludes lbi) (installIncludes lbi) + relincdirs = fmap getSymbolicPath $ sameDirectory : mapMaybe symbolicPathRelative_maybe (includeDirs lbi) + traverse (fmap (makeSymbolicPath . snd) . findIncludeFile verbosity cwd relincdirs) incls + , -- Setup script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupFile cwd + , -- SetupHooks script, if it exists. + fmap (maybe [] (\f -> [makeSymbolicPath f])) $ findSetupHooksFile cwd + , -- The .cabal file itself. + fmap (\d -> [d]) (coerceSymbolicPath . relativeSymbolicPath <$> tryFindPackageDesc verbosity mbWorkDir) + ] where + cwd = maybe "." getSymbolicPath mbWorkDir -- We have to deal with all libs and executables, so we have local -- versions of these functions that ignore the 'buildable' attribute: - withAllLib action = traverse action (allLibraries pkg_descr) - withAllFLib action = traverse action (foreignLibs pkg_descr) - withAllExe action = traverse action (executables pkg_descr) - withAllTest action = traverse action (testSuites pkg_descr) + withAllLib action = traverse action (allLibraries pkg_descr) + withAllFLib action = traverse action (foreignLibs pkg_descr) + withAllExe action = traverse action (executables pkg_descr) + withAllTest action = traverse action (testSuites pkg_descr) withAllBenchmark action = traverse action (benchmarks pkg_descr) - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO () -prepareTree verbosity pkg_descr0 targetDir pps = do - ordinary <- listPackageSources verbosity "." pkg_descr pps - installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary) - maybeCreateDefaultSetupScript targetDir +-- | Prepare a directory tree of source files. +prepareTree + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity mbWorkDir pkg_descr0 targetDir pps = do + ordinary <- listPackageSources verbosity mbWorkDir pkg_descr pps + installOrdinaryFiles verbosity targetDir (zip (repeat []) $ map i ordinary) + maybeCreateDefaultSetupScript targetDir where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path pkg_descr = filterAutogenModules pkg_descr0 -- | Find the setup script file, if it exists. findSetupFile :: FilePath -> IO (Maybe FilePath) findSetupFile targetDir = do - hsExists <- doesFileExist (targetDir setupHs) + hsExists <- doesFileExist (targetDir setupHs) lhsExists <- doesFileExist (targetDir setupLhs) if hsExists then return (Just setupHs) - else if lhsExists - then return (Just setupLhs) - else return Nothing - where - setupHs = "Setup.hs" - setupLhs = "Setup.lhs" + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "Setup.hs" + setupLhs = "Setup.lhs" +-- | Find the setup hooks script file, if it exists. +findSetupHooksFile :: FilePath -> IO (Maybe FilePath) +findSetupHooksFile targetDir = do + hsExists <- doesFileExist (targetDir setupHs) + lhsExists <- doesFileExist (targetDir setupLhs) + if hsExists + then return (Just setupHs) + else + if lhsExists + then return (Just setupLhs) + else return Nothing + where + setupHs = "SetupHooks.hs" + setupLhs = "SetupHooks.lhs" + -- | Create a default setup script in the target directory, if it doesn't exist. maybeCreateDefaultSetupScript :: FilePath -> IO () maybeCreateDefaultSetupScript targetDir = do mSetupFile <- findSetupFile targetDir case mSetupFile of Just _setupFile -> return () - Nothing -> do - writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] + Nothing -> do + writeUTF8File (targetDir "Setup.hs") $ + unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] -- | Find the main executable file. findMainExeFile :: Verbosity - -> FilePath -- ^ cwd + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory -> BuildInfo -> [PPSuffixHandler] - -> FilePath -- ^ main-is - -> IO FilePath + -> RelativePath Source File + -- ^ main-is + -> IO (SymbolicPath Pkg File) findMainExeFile verbosity cwd exeBi pps mainPath = do - ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi)) - (dropExtension mainPath) + ppFile <- + findFileCwdWithExtension + cwd + (ppSuffixes pps) + (hsSourceDirs exeBi) + (dropExtensionsSymbolicPath mainPath) case ppFile of - Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath + Nothing -> findFileCwd verbosity cwd (hsSourceDirs exeBi) mainPath Just pp -> return pp -- | Find a module definition file -- -- TODO: I don't know if this is right findModDefFile - :: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> BuildInfo + -> [PPSuffixHandler] + -> RelativePath Source File + -> IO (SymbolicPath Pkg File) findModDefFile verbosity cwd flibBi _pps modDefPath = - findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath + findFileCwd verbosity cwd (sameDirectory : hsSourceDirs flibBi) modDefPath -- | Given a list of include paths, try to find the include file named -- @f@. Return the name of the file and the full path, or exit with error if -- there's no such file. findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath) -findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f) -findIncludeFile verbosity cwd (d:ds) f = do - let path = (d f) +findIncludeFile verbosity _ [] f = dieWithException verbosity $ NoIncludeFileFound f +findIncludeFile verbosity cwd (d : ds) f = do + let path = d f b <- doesFileExist (cwd path) - if b then return (f,path) else findIncludeFile verbosity cwd ds f + if b then return (f, path) else findIncludeFile verbosity cwd ds f --- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' +-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules' -- and 'other-modules'. filterAutogenModules :: PackageDescription -> PackageDescription -filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $ - mapAllBuildInfo filterAutogenModuleBI pkg_descr0 +filterAutogenModules pkg_descr0 = + mapLib filterAutogenModuleLib $ + mapAllBuildInfo filterAutogenModuleBI pkg_descr0 where - mapLib f pkg = pkg { library = fmap f (library pkg) - , subLibraries = map f (subLibraries pkg) } - filterAutogenModuleLib lib = lib { - exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) - } - filterAutogenModuleBI bi = bi { - otherModules = filter (filterFunction bi) (otherModules bi) - } + mapLib f pkg = + pkg + { library = fmap f (library pkg) + , subLibraries = map f (subLibraries pkg) + } + filterAutogenModuleLib lib = + lib + { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib) + } + filterAutogenModuleBI bi = + bi + { otherModules = filter (filterFunction bi) (otherModules bi) + } pathsModule = autogenPathsModuleName pkg_descr0 + packageInfoModule = autogenPackageInfoModuleName pkg_descr0 filterFunction bi = \mn -> - mn /= pathsModule - && not (mn `elem` autogenModules bi) + mn /= pathsModule + && mn /= packageInfoModule + && not (mn `elem` autogenModules bi) -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- prepareSnapshotTree - :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + :: Verbosity + -- ^ verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree to populate + -> [PPSuffixHandler] + -- ^ extra preprocessors (includes suffixes) -> IO () -prepareSnapshotTree verbosity pkg targetDir pps = do - prepareTree verbosity pkg targetDir pps +prepareSnapshotTree verbosity mbWorkDir pkg targetDir pps = do + prepareTree verbosity mbWorkDir pkg targetDir pps overwriteSnapshotPackageDesc verbosity pkg targetDir -overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^source tree - -> IO () +overwriteSnapshotPackageDesc + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from the cabal file + -> FilePath + -- ^ source tree + -> IO () overwriteSnapshotPackageDesc verbosity pkg targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion (packageVersion pkg)) . lines - + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- getSymbolicPath <$> defaultPackageDescCwd verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines + . map (replaceVersion (packageVersion pkg)) + . lines where replaceVersion :: Version -> String -> String replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ prettyShow version + | "version:" `isPrefixOf` map toLower line = + "version: " ++ prettyShow version | otherwise = line -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. --- snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg + pkg + { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)} + } + where + pkgid = packageId pkg -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. --- snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date]) -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@. --- dateToSnapshotNumber :: UTCTime -> Int dateToSnapshotNumber date = case toGregorian (utctDay date) of - (year, month, day) -> - fromIntegral year * 10000 - + month * 100 - + day + (year, month, day) -> + fromIntegral year * 10000 + + month * 100 + + day -- | Create an archive from a tree of source files, and clean up the tree. createArchive - :: Verbosity -- ^ verbosity - -> PackageDescription -- ^ info from cabal file - -> FilePath -- ^ source tree to archive - -> FilePath -- ^ name of archive to create - -> IO FilePath + :: Verbosity + -- ^ verbosity + -> PackageDescription + -- ^ info from cabal file + -> FilePath + -- ^ source tree to archive + -> FilePath + -- ^ name of archive to create + -> IO FilePath createArchive verbosity pkg_descr tmpDir targetPref = do let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" (tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb - let formatOptSupported = maybe False (== "YES") $ - Map.lookup "Supports --format" - (programProperties tarProg) + let formatOptSupported = + maybe False (== "YES") $ + Map.lookup + "Supports --format" + (programProperties tarProg) runProgram verbosity tarProg $ -- Hmm: I could well be skating on thinner ice here by using the -C option -- (=> seems to be supported at least by GNU and *BSD tar) [The -- prev. solution used pipes and sub-command sequences to set up the paths -- correctly, which is problematic in a Windows setting.] ["-czf", tarBallFilePath, "-C", tmpDir] - ++ (if formatOptSupported then ["--format", "ustar"] else []) - ++ [tarBallName pkg_descr] + ++ (if formatOptSupported then ["--format", "ustar"] else []) + ++ [tarBallName pkg_descr] return tarBallFilePath -- | Given a buildinfo, return the names of all source files. allSourcesBuildInfo - :: Verbosity - -> (Verbosity -> String -> IO [FilePath]) - -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir' - -> BuildInfo - -> [PPSuffixHandler] -- ^ Extra preprocessors - -> [ModuleName] -- ^ Exposed modules - -> IO [FilePath] -allSourcesBuildInfo verbosity rip cwd bi pps modules = do - let searchDirs = map getSymbolicPath (hsSourceDirs bi) - sources <- fmap concat $ sequenceA $ - [ let file = ModuleName.toFilePath module_ - -- NB: *Not* findFileWithExtension, because the same source - -- file may show up in multiple paths due to a conditional; - -- we need to package all of them. See #367. - in findAllFilesCwdWithExtension cwd suffixes searchDirs file - >>= nonEmpty' (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequenceA - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file - | module_ <- modules ++ otherModules bi ] - - return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++ - cmmSources bi ++ asmSources bi ++ jsSources bi + :: Verbosity + -> (Verbosity -> CabalException -> IO [SymbolicPath Pkg File]) + -- ^ 'die'' alternative. + -- Since 'die'' prefixes the error message with 'errorPrefix', + -- whatever is passed in here and wants to die should do the same. + -- See issue #7331. + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> BuildInfo + -> [PPSuffixHandler] + -- ^ Extra preprocessors + -> [ModuleName] + -- ^ Exposed modules + -> IO [SymbolicPath Pkg File] +allSourcesBuildInfo verbosity rip mbWorkDir bi pps modules = do + let searchDirs = hsSourceDirs bi + sources <- + fmap concat $ + sequenceA $ + [ let file = moduleNameSymbolicPath module_ + in -- NB: *Not* findFileWithExtension, because the same source + -- file may show up in multiple paths due to a conditional; + -- we need to package all of them. See #367. + findAllFilesCwdWithExtension mbWorkDir suffixes searchDirs file + >>= nonEmpty' (notFound module_) return + | module_ <- modules ++ otherModules bi + ] + bootFiles <- + sequenceA + [ let file = moduleNameSymbolicPath module_ + fileExts = builtinHaskellBootSuffixes + in findFileCwdWithExtension mbWorkDir fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi + ] + return $ + sources + ++ catMaybes bootFiles + ++ cSources bi + ++ cxxSources bi + ++ cmmSources bi + ++ asmSources bi + ++ jsSources bi where nonEmpty' :: b -> ([a] -> b) -> [a] -> b nonEmpty' x _ [] = x nonEmpty' _ f xs = f xs - suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"] - - notFound :: ModuleName -> IO [FilePath] - notFound m = rip verbosity $ "Error: Could not find module: " ++ prettyShow m - ++ " with any suffix: " ++ show suffixes ++ ". If the module " - ++ "is autogenerated it should be added to 'autogen-modules'." + suffixes = ppSuffixes pps ++ builtinHaskellSuffixes + notFound :: ModuleName -> IO [SymbolicPath Pkg File] + notFound m = + rip verbosity $ NoModuleFound m suffixes -- | Note: must be called with the CWD set to the directory containing -- the '.cabal' file. printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles verbosity pkg_descr "." + ioChecks <- checkPackageFiles verbosity pkg_descr "." let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError (PackageDistSuspiciousWarn _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + (errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks) unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map explanation errors) + notice verbosity $ + "Distribution quality errors:\n" + ++ unlines (map ppPackageCheck errors) unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) + notice verbosity $ + "Distribution quality warnings:\n" + ++ unlines (map ppPackageCheck warnings) unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." + notice + verbosity + "Note: the public hackage server would reject this package." ------------------------------------------------------------ -- | The name of the tarball without extension --- tarBallName :: PackageDescription -> String tarBallName = prettyShow . packageId -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - subLibraries = fmap mapLibBi (subLibraries pkg), - foreignLibs = fmap mapFLibBi (foreignLibs pkg), - executables = fmap mapExeBi (executables pkg), - testSuites = fmap mapTestBi (testSuites pkg), - benchmarks = fmap mapBenchBi (benchmarks pkg) - } +mapAllBuildInfo + :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = + pkg + { library = fmap mapLibBi (library pkg) + , subLibraries = fmap mapLibBi (subLibraries pkg) + , foreignLibs = fmap mapFLibBi (foreignLibs pkg) + , executables = fmap mapExeBi (executables pkg) + , testSuites = fmap mapTestBi (testSuites pkg) + , benchmarks = fmap mapBenchBi (benchmarks pkg) + } where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } - mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) } - mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) } + mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)} + mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)} + mapExeBi exe = exe{buildInfo = f (buildInfo exe)} + mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)} + mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)} diff --git a/src/Distribution/Simple/Test.hs b/src/Distribution/Simple/Test.hs --- a/src/Distribution/Simple/Test.hs +++ b/src/Distribution/Simple/Test.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.Test -- Copyright : Thomas Tuegel 2010 @@ -13,124 +18,191 @@ -- This is the entry point into testing a built package. It performs the -- \"@.\/setup test@\" action. It runs test suites designated in the package -- description and reports on the results. - module Distribution.Simple.Test - ( test - ) where + ( test + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty +import Distribution.Simple.Build (addInternalBuildTools) import Distribution.Simple.Compiler import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup -import Distribution.Simple.UserHooks +import Distribution.Simple.Setup.Test import qualified Distribution.Simple.Test.ExeV10 as ExeV10 import qualified Distribution.Simple.Test.LibV09 as LibV09 import Distribution.Simple.Test.Log +import Distribution.Simple.UserHooks import Distribution.Simple.Utils import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Types.UnqualComponentName +import Distribution.Utils.Path +import Distribution.Simple.Configure (getInstalledPackagesById) +import Distribution.Simple.Errors +import Distribution.Simple.Register (internalPackageDBPath) +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config +import Distribution.Types.ExposedModule +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (libraryDirs), exposedModules) +import Distribution.Types.LocalBuildInfo (LocalBuildInfo (..)) import System.Directory - ( createDirectoryIfMissing, doesFileExist, getDirectoryContents - , removeFile ) -import System.FilePath ( () ) - --- |Perform the \"@.\/setup test@\" action. -test :: Args -- ^positional command-line arguments - -> PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> TestFlags -- ^flags sent to test - -> IO () -test args pkg_descr lbi flags = do - let verbosity = fromFlag $ testVerbosity flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = args - pkgTests = PD.testSuites pkg_descr - enabledTests = LBI.enabledTestLBIs pkg_descr lbi - - doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo), - Maybe TestSuiteLog) -> IO TestSuiteLog - doTest ((suite, clbi), _) = - case PD.testInterface suite of - PD.TestSuiteExeV10 _ _ -> - ExeV10.runTest pkg_descr lbi clbi flags suite + ( createDirectoryIfMissing + , doesFileExist + , getDirectoryContents + , removeFile + ) - PD.TestSuiteLibV09 _ _ -> - LibV09.runTest pkg_descr lbi clbi flags suite +-- | Perform the \"@.\/setup test@\" action. +test + :: Args + -- ^ positional command-line arguments + -> PD.PackageDescription + -- ^ information from the .cabal file + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> TestFlags + -- ^ flags sent to test + -> IO () +test args pkg_descr lbi0 flags = do + curDir <- LBI.absoluteWorkingDirLBI lbi0 + let common = testCommonFlags flags + verbosity = fromFlag $ setupVerbosity common + distPref = fromFlag $ setupDistPref common + i = LBI.interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + machineTemplate = fromFlag $ testMachineLog flags + testLogDir = distPref makeRelativePathEx "test" + testNames = args + pkgTests = PD.testSuites pkg_descr + enabledTests = LBI.enabledTestLBIs pkg_descr lbi + -- We must add the internalPkgDB to the package database stack to lookup + -- the path to HPC dirs of libraries local to this package + internalPkgDb = internalPackageDBPath lbi0 distPref + lbi = lbi0{withPackageDB = withPackageDB lbi0 ++ [SpecificPackageDB internalPkgDb]} - _ -> return TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = TestLog + doTest + :: HPCMarkupInfo + -> ( (PD.TestSuite, LBI.ComponentLocalBuildInfo) + , Maybe TestSuiteLog + ) + -> IO TestSuiteLog + doTest hpcMarkupInfo ((suite, clbi), _) = do + let lbiForTest = + lbi + { withPrograms = + -- Include any build-tool-depends on build tools internal to the current package. + addInternalBuildTools + curDir + pkg_descr + lbi + (PD.testBuildInfo suite) + (withPrograms lbi) + } + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> + ExeV10.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + PD.TestSuiteLibV09 _ _ -> + LibV09.runTest pkg_descr lbiForTest clbi hpcMarkupInfo flags suite + _ -> + return + TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = + TestLog { testName = unUnqualComponentName $ PD.testName suite , testOptionsReturned = [] , testResult = - Error $ "No support for running test suite type: " - ++ show (pretty $ PD.testType suite) + Error $ + "No support for running test suite type: " + ++ show (pretty $ PD.testType suite) } - , logFile = "" - } + , logFile = "" + } - unless (PD.hasTests pkg_descr) $ do - notice verbosity "Package has no test suites." - exitSuccess + unless (PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitSuccess - when (PD.hasTests pkg_descr && null enabledTests) $ - die' verbosity $ - "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" + when (PD.hasTests pkg_descr && null enabledTests) $ + dieWithException verbosity NoTestSuitesEnabled - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> for names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map (PD.testName . fst) enabledTests - allNames = map PD.testName pkgTests - tCompName = mkUnqualComponentName tName - in case lookup tCompName testMap of - Just t -> return (t, Nothing) - _ | tCompName `elem` allNames -> - die' verbosity $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die' verbosity $ "no such test: " ++ tName + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> for names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map (PD.testName . fst) enabledTests + allNames = map PD.testName pkgTests + tCompName = mkUnqualComponentName tName + in case lookup tCompName testMap of + Just t -> return (t, Nothing) + _ + | tCompName `elem` allNames -> + dieWithException verbosity $ TestNameDisabled tName + | otherwise -> dieWithException verbosity $ NoSuchTest tName - createDirectoryIfMissing True testLogDir + createDirectoryIfMissing True $ i testLogDir - -- Delete ordinary files from test log directory. - getDirectoryContents testLogDir - >>= filterM doesFileExist . map (testLogDir ) - >>= traverse_ removeFile + -- Delete ordinary files from test log directory. + getDirectoryContents (i testLogDir) + >>= filterM doesFileExist . map (i testLogDir ) + >>= traverse_ removeFile - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- traverse doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog + -- We configured the unit-ids of libraries we should cover in our coverage + -- report at configure time into the local build info. At build time, we built + -- the hpc artifacts into the extraCompilationArtifacts directory, which, at + -- install time, is copied into the ghc-pkg database files. + -- Now, we get the path to the HPC artifacts and exposed modules of each + -- library by querying the package database keyed by unit-id: + let coverageFor = + nub $ + fromFlagOrDefault [] (configCoverageFor (configFlags lbi)) + <> extraCoverageFor lbi + ipkginfos <- getInstalledPackagesById verbosity lbi MissingCoveredInstalledLibrary coverageFor + let ( concat -> pathsToLibsArtifacts + , concat -> libsModulesToInclude + ) = + unzip $ + map + ( \ip -> + ( map (( coerceSymbolicPath extraCompilationArtifacts) . makeSymbolicPath) $ libraryDirs ip + , map exposedName $ exposedModules ip + ) + ) + ipkginfos + hpcMarkupInfo = HPCMarkupInfo{pathsToLibsArtifacts, libsModulesToInclude} - when (LBI.testCoverage lbi) $ - markupPackage verbosity lbi distPref pkg_descr $ - map (fst . fst) testsToRun + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- traverse (doTest hpcMarkupInfo) testsToRun + let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites} + packageLogFile = + i testLogDir + packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog - unless allOk exitFailure + when (LBI.testCoverage lbi) $ + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr $ + map (fst . fst) testsToRun -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath + unless allOk exitFailure + +packageLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) diff --git a/src/Distribution/Simple/Test/ExeV10.hs b/src/Distribution/Simple/Test/ExeV10.hs --- a/src/Distribution/Simple/Test/ExeV10.hs +++ b/src/Distribution/Simple/Test/ExeV10.hs @@ -2,192 +2,253 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.ExeV10 - ( runTest - ) where + ( runTest + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.UnqualComponentName -import Distribution.Compat.CreatePipe -import Distribution.Compat.Environment import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Errors +import Distribution.Simple.Flag import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup + ( ComponentLocalBuildInfo (..) + , buildDir + , depLibraryPaths + ) +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI + ( LocalBuildInfo (..) + , localUnitId + , testCoverage + ) +import Distribution.Types.UnqualComponentName import Distribution.Verbosity -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive ) -import System.FilePath ( (), (<.>) ) -import System.IO ( stdout, stderr ) +import Distribution.Utils.Path import qualified Data.ByteString.Lazy as LBS - -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi - tixDir_ = tixDir distPref way testName' +import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI, packageRoot) +import System.Directory + ( createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , removeDirectoryRecursive + ) +import System.IO (stderr, stdout) +import System.Process (createPipe) - pwd <- getCurrentDirectory - existingEnv <- getEnvironment +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi + tixDir_ = i $ tixDir distPref way - let cmd = LBI.buildDir lbi testName' - testName' <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ die' verbosity $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" + let cmd = + i (LBI.buildDir lbi) + testName' + testName' <.> exeExtension (LBI.hostPlatform lbi) + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgram cmd - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - exists' <- doesDirectoryExist tixDir_ - when exists' $ removeDirectoryRecursive tixDir_ + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tixDir_ + when exists' $ removeDirectoryRecursive tixDir_ - -- Create directory for HPC files. - createDirectoryIfMissing True tixDir_ + -- Create directory for HPC files. + createDirectoryIfMissing True tixDir_ - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ testName' + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ testName' + -- Run the test executable (with the appropriate environment set) + let progDb = LBI.withPrograms lbi + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar + let opts = + map + (testOption pkg_descr lbi suite) + (testOptions flags) + tixFile = packageRoot (testCommonFlags flags) getSymbolicPath (tixFilePath distPref way (testName')) - -- Run the test executable - let opts = map (testOption pkg_descr lbi suite) - (testOptions flags) - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way (testName') - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv + shellEnv <- + getFullEnvironment + ( [("PATH", Just newPath)] + ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled] + ++ envOverrides + ) - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- if LBI.withDynExe lbi - then do let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - return (addLibraryPath os paths shellEnv) - else return shellEnv + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + return (addLibraryPath os paths shellEnv) + else return shellEnv - -- Output logger - (wOut, wErr, getLogText) <- case details of - Direct -> return (stdout, stderr, return LBS.empty) - _ -> do - (rOut, wOut) <- createPipe + -- Output logger + (wOut, wErr, getLogText) <- case details of + Direct -> return (stdout, stderr, return LBS.empty) + _ -> do + (rOut, wOut) <- createPipe - return $ (,,) wOut wOut $ do - -- Read test executables' output - logText <- LBS.hGetContents rOut + return $ (,,) wOut wOut $ do + -- Read test executables' output + logText <- LBS.hGetContents rOut - -- '--show-details=streaming': print the log output in another thread - when (details == Streaming) $ LBS.putStr logText + -- '--show-details=streaming': print the log output in another thread + when (details == Streaming) $ LBS.putStr logText - -- drain the output. - evaluate (force logText) + -- drain the output. + evaluate (force logText) - (exit, logText) <- case testWrapper flags of - Flag path -> rawSystemIOWithEnvAndAction - verbosity path (cmd:opts) Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + let mbWorkDir = + interpretSymbolicPathCWD + <$> flagToMaybe (setupWorkingDir (testCommonFlags flags)) - NoFlag -> rawSystemIOWithEnvAndAction - verbosity cmd opts Nothing (Just shellEnv') - getLogText - -- these handles are automatically closed - Nothing (Just wOut) (Just wErr) + (exit, logText) <- case testWrapper flags of + Flag path -> + rawSystemIOWithEnvAndAction + verbosity + path + (cmd : opts) + mbWorkDir + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) + NoFlag -> + rawSystemIOWithEnvAndAction + verbosity + cmd + opts + mbWorkDir + (Just shellEnv') + getLogText + -- these handles are automatically closed + Nothing + (Just wOut) + (Just wErr) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log. - let suiteLog = buildLog exit + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log. + let suiteLog = buildLog exit - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart $ testName' + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - -- Append contents of temporary log file to the final human- - -- readable log file - LBS.appendFile (logFile suiteLog) logText + -- Append contents of temporary log file to the final human- + -- readable log file + LBS.appendFile (logFile suiteLog) logText - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let whenPrinting = when $ - ( details == Always || - details == Failures && not (suitePassed $ testLogs suiteLog)) + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let whenPrinting = + when $ + ( details == Always + || details == Failures && not (suitePassed $ testLogs suiteLog) + ) -- verbosity overrides show-details && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' + whenPrinting $ do + LBS.putStr logText + putChar '\n' - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] - return suiteLog + return suiteLog where + i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path + commonFlags = testCommonFlags flags + testName' = unUnqualComponentName $ PD.testName suite - distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags + distPref = fromFlag $ setupDistPref commonFlags + verbosity = fromFlag $ setupVerbosity commonFlags details = fromFlag $ testShowDetails flags - testLogDir = distPref "test" + testLogDir = distPref makeRelativePathEx "test" buildLog exit = - let r = case exit of - ExitSuccess -> Pass - ExitFailure c -> Fail $ "exit code: " ++ show c - --n = unUnqualComponentName $ PD.testName suite - l = TestLog - { testName = testName' - , testOptionsReturned = [] - , testResult = r - } - in TestSuiteLog - { testSuiteName = PD.testName suite - , testLogs = l - , logFile = - testLogDir - testSuiteLogPath (fromFlag $ testHumanLog flags) - pkg_descr lbi testName' l - } + let r = case exit of + ExitSuccess -> Pass + ExitFailure c -> Fail $ "exit code: " ++ show c + -- n = unUnqualComponentName $ PD.testName suite + l = + TestLog + { testName = testName' + , testOptionsReturned = [] + , testResult = r + } + in TestSuiteLog + { testSuiteName = PD.testName suite + , testLogs = l + , logFile = + i testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + testName' + l + } -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] diff --git a/src/Distribution/Simple/Test/LibV09.hs b/src/Distribution/Simple/Test/LibV09.hs --- a/src/Distribution/Simple/Test/LibV09.hs +++ b/src/Distribution/Simple/Test/LibV09.hs @@ -1,115 +1,140 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.LibV09 - ( runTest - -- Test stub - , simpleTestStub - , stubFilePath, stubMain, stubName, stubWriteLog - , writeSimpleTestStub - ) where + ( runTest + -- Test stub + , simpleTestStub + , stubFilePath + , stubMain + , stubName + , stubWriteLog + , writeSimpleTestStub + ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.Types.UnqualComponentName +import Prelude () -import Distribution.Compat.CreatePipe -import Distribution.Compat.Environment import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Process (proc) import Distribution.ModuleName import qualified Distribution.PackageDescription as PD -import Distribution.Simple.Build.PathsModule +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler +import Distribution.Simple.Errors import Distribution.Simple.Hpc import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import qualified Distribution.Types.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Find +import Distribution.Simple.Program.Run +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Test import Distribution.Simple.Test.Log import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite -import Distribution.Pretty +import qualified Distribution.Types.LocalBuildInfo as LBI +import Distribution.Utils.Path import Distribution.Verbosity import qualified Control.Exception as CE import qualified Data.ByteString.Lazy as LBS import System.Directory - ( createDirectoryIfMissing, canonicalizePath - , doesDirectoryExist, doesFileExist - , getCurrentDirectory, removeDirectoryRecursive, removeFile - , setCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, hPutStr ) -import System.Process (StdStream(..), waitForProcess) - -runTest :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> LBI.ComponentLocalBuildInfo - -> TestFlags - -> PD.TestSuite - -> IO TestSuiteLog -runTest pkg_descr lbi clbi flags suite = do - let isCoverageEnabled = LBI.testCoverage lbi - way = guessWay lbi + ( canonicalizePath + , createDirectoryIfMissing + , doesDirectoryExist + , doesFileExist + , getCurrentDirectory + , removeDirectoryRecursive + , removeFile + , setCurrentDirectory + ) +import System.IO (hClose, hPutStr) +import qualified System.Process as Process - pwd <- getCurrentDirectory - existingEnv <- getEnvironment +runTest + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> LBI.ComponentLocalBuildInfo + -> HPCMarkupInfo + -> TestFlags + -> PD.TestSuite + -> IO TestSuiteLog +runTest pkg_descr lbi clbi hpcMarkupInfo flags suite = do + let isCoverageEnabled = LBI.testCoverage lbi + way = guessWay lbi - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension (LBI.hostPlatform lbi) - -- Check that the test executable exists. - exists <- doesFileExist cmd - unless exists $ - die' verbosity $ "Error: Could not find test program \"" ++ cmd - ++ "\". Did you build the package first?" + let mbWorkDir = LBI.mbWorkDirLBI lbi - -- Remove old .tix files if appropriate. - unless (fromFlag $ testKeepTix flags) $ do - let tDir = tixDir distPref way testName' - exists' <- doesDirectoryExist tDir - when exists' $ removeDirectoryRecursive tDir + let cmd = + interpretSymbolicPath mbWorkDir (LBI.buildDir lbi) + stubName suite + stubName suite <.> exeExtension (LBI.hostPlatform lbi) + tDir = i $ tixDir distPref way + -- Check that the test executable exists. + exists <- doesFileExist cmd + unless exists $ + dieWithException verbosity $ + Couldn'tFindTestProgLibV09 cmd - -- Create directory for HPC files. - createDirectoryIfMissing True $ tixDir distPref way testName' + -- Remove old .tix files if appropriate. + unless (fromFlag $ testKeepTix flags) $ do + exists' <- doesDirectoryExist tDir + when exists' $ removeDirectoryRecursive tDir - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart testName' + -- Create directory for HPC files. + createDirectoryIfMissing True tDir - suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart testName' - -- TODO: this setup is broken, - -- if the test output is too big, we will deadlock. - (rOut, wOut) <- createPipe + suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do + -- Compute the appropriate environment for running the test suite + let progDb = LBI.withPrograms lbi + pathVar = progSearchPath progDb + envOverrides = progOverrideEnv progDb + newPath <- programSearchPathAsPATHVar pathVar - -- Run test executable - (Just wIn, _, _, process) <- do - let opts = map (testOption pkg_descr lbi suite) $ testOptions flags - dataDirPath = pwd PD.dataDir pkg_descr - tixFile = pwd tixFilePath distPref way testName' - pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] - ++ pkgPathEnv - -- Add (DY)LD_LIBRARY_PATH if needed - shellEnv' <- - if LBI.withDynExe lbi - then do - let (Platform _ os) = LBI.hostPlatform lbi - paths <- LBI.depLibraryPaths True False lbi clbi - cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi - return (addLibraryPath os (cpath : paths) shellEnv) - else return shellEnv - case testWrapper flags of - Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv') - -- these handles are closed automatically - CreatePipe (UseHandle wOut) (UseHandle wOut) + -- Run test executable + let opts = map (testOption pkg_descr lbi suite) $ testOptions flags + tixFile = i $ tixFilePath distPref way testName' - NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv') - -- these handles are closed automatically - CreatePipe (UseHandle wOut) (UseHandle wOut) + shellEnv <- + getFullEnvironment + ( [("PATH", Just newPath)] + ++ [("HPCTIXFILE", Just tixFile) | isCoverageEnabled] + ++ envOverrides + ) + -- Add (DY)LD_LIBRARY_PATH if needed + shellEnv' <- + if LBI.withDynExe lbi + then do + let (Platform _ os) = LBI.hostPlatform lbi + paths <- LBI.depLibraryPaths True False lbi clbi + cpath <- canonicalizePath $ i $ LBI.componentBuildDir lbi clbi + return (addLibraryPath os (cpath : paths) shellEnv) + else return shellEnv + let (cmd', opts') = case testWrapper flags of + Flag path -> (path, cmd : opts) + NoFlag -> (cmd, opts) + -- TODO: this setup is broken, + -- if the test output is too big, we will deadlock. + (rOut, wOut) <- Process.createPipe + (exitcode, logText) <- rawSystemProcAction + verbosity + (proc cmd' opts') + { Process.env = Just shellEnv' + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.UseHandle wOut + , Process.std_err = Process.UseHandle wOut + } + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn hPutStr wIn $ show (tempLog, PD.testName suite) hClose wIn @@ -118,112 +143,132 @@ logText <- LBS.hGetContents rOut -- Force the IO manager to drain the test output pipe _ <- evaluate (force logText) - - exitcode <- waitForProcess process - unless (exitcode == ExitSuccess) $ do - debug verbosity $ cmd ++ " returned " ++ show exitcode + return logText + unless (exitcode == ExitSuccess) $ + debug verbosity $ + cmd ++ " returned " ++ show exitcode - -- Generate final log file name - let finalLogName l = testLogDir - testSuiteLogPath - (fromFlag $ testHumanLog flags) pkg_descr lbi - (unUnqualComponentName $ testSuiteName l) (testLogs l) - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l }) - . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse - $ readFile tempLog + -- Generate final log file name + let finalLogName l = + interpretSymbolicPath mbWorkDir testLogDir + testSuiteLogPath + (fromFlag $ testHumanLog flags) + pkg_descr + lbi + (unUnqualComponentName $ testSuiteName l) + (testLogs l) + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- + fmap + ( \s -> + (\l -> l{logFile = finalLogName l}) + . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) + $ readMaybe s -- TODO: eradicateNoParse + ) + $ readFile tempLog - -- Write summary notice to log file indicating start of test suite - appendFile (logFile suiteLog) $ summarizeSuiteStart testName' + -- Write summary notice to log file indicating start of test suite + appendFile (logFile suiteLog) $ summarizeSuiteStart testName' - LBS.appendFile (logFile suiteLog) logText + LBS.appendFile (logFile suiteLog) logText - -- Write end-of-suite summary notice to log file - appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog + -- Write end-of-suite summary notice to log file + appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let details = fromFlag $ testShowDetails flags - whenPrinting = when $ (details > Never) - && (not (suitePassed $ testLogs suiteLog) || details == Always) - && verbosity >= normal - whenPrinting $ do - LBS.putStr logText - putChar '\n' + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = + when $ + (details > Never) + && (not (suitePassed $ testLogs suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ do + LBS.putStr logText + putChar '\n' - return suiteLog + return suiteLog - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog - when isCoverageEnabled $ - case PD.library pkg_descr of - Nothing -> - die' verbosity $ "Error: test coverage is only supported for packages with a library component" + when isCoverageEnabled $ do + -- Until #9493 is fixed, we expect cabal-install to pass one dist dir per + -- library and there being at least one library in the package with the + -- testsuite. When it is fixed, we can remove this predicate and allow a + -- testsuite without a library to cover libraries in other packages of the + -- same project + when (null $ PD.allLibraries pkg_descr) $ + dieWithException verbosity TestCoverageSupport - Just library -> - markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library + markupPackage verbosity hpcMarkupInfo lbi distPref pkg_descr [suite] - return suiteLog + return suiteLog where + i = LBI.interpretSymbolicPathLBI lbi + common = testCommonFlags flags testName' = unUnqualComponentName $ PD.testName suite deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file + exists <- doesFileExist file + when exists $ removeFile file - testLogDir = distPref "test" + testLogDir = distPref makeRelativePathEx "test" openCabalTemp = do - (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" - hClose h >> return f + (f, h) <- openTempFile (i testLogDir) $ "cabal-test-" <.> "log" + hClose h >> return f - distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags + distPref = fromFlag $ setupDistPref common + verbosity = fromFlag $ setupVerbosity common -- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't -- necessarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String +testOption + :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template + fromPathTemplate $ substPathTemplate env template where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)] -- Test stub ---------- --- | The name of the stub executable associated with a library 'TestSuite'. -stubName :: PD.TestSuite -> FilePath -stubName t = unUnqualComponentName (PD.testName t) ++ "Stub" - -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'. stubFilePath :: PD.TestSuite -> FilePath stubFilePath t = stubName t <.> "hs" -- | Write the source file for a library 'TestSuite' stub executable. -writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub - -- is being created - -> FilePath -- ^ path to directory where stub source - -- should be located - -> IO () +writeSimpleTestStub + :: PD.TestSuite + -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath + -- ^ path to directory where stub source + -- should be located + -> IO () writeSimpleTestStub t dir = do - createDirectoryIfMissing True dir - let filename = dir stubFilePath t - m = case PD.testInterface t of - PD.TestSuiteLibV09 _ m' -> m' - _ -> error "writeSimpleTestStub: invalid TestSuite passed" - writeFile filename $ simpleTestStub m + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + m = case PD.testInterface t of + PD.TestSuiteLibV09 _ m' -> m' + _ -> error "writeSimpleTestStub: invalid TestSuite passed" + writeFile filename $ simpleTestStub m -- | Source code for library test suite stub executable simpleTestStub :: ModuleName -> String -simpleTestStub m = unlines +simpleTestStub m = + unlines [ "module Main ( main ) where" , "import Distribution.Simple.Test.LibV09 ( stubMain )" , "import " ++ show (pretty m) ++ " ( tests )" @@ -236,18 +281,22 @@ -- of detectable errors when Cabal is compiled. stubMain :: IO [Test] -> IO () stubMain tests = do - (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse - dir <- getCurrentDirectory - results <- (tests >>= stubRunTests) `CE.catch` errHandler - setCurrentDirectory dir - stubWriteLog f n results + (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse + dir <- getCurrentDirectory + results <- (tests >>= stubRunTests) `CE.catch` errHandler + setCurrentDirectory dir + stubWriteLog f n results where errHandler :: CE.SomeException -> IO TestLogs errHandler e = case CE.fromException e of - Just CE.UserInterrupt -> CE.throwIO e - _ -> return $ TestLog { testName = "Cabal test suite exception", - testOptionsReturned = [], - testResult = Error $ show e } + Just CE.UserInterrupt -> CE.throwIO e + _ -> + return $ + TestLog + { testName = "Cabal test suite exception" + , testOptionsReturned = [] + , testResult = Error $ show e + } -- | The test runner used in library "TestSuite" stub executables. Runs a list -- of 'Test's. An executable calling this function is meant to be invoked as @@ -258,35 +307,36 @@ -- by the calling Cabal process. stubRunTests :: [Test] -> IO TestLogs stubRunTests tests = do - logs <- traverse stubRunTests' tests - return $ GroupLogs "Default" logs + logs <- traverse stubRunTests' tests + return $ GroupLogs "Default" logs where stubRunTests' (Test t) = do - l <- run t >>= finish - summarizeTest normal Always l - return l + l <- run t >>= finish + summarizeTest normal Always l + return l where finish (Finished result) = - return TestLog - { testName = name t - , testOptionsReturned = defaultOptions t - , testResult = result - } + return + TestLog + { testName = name t + , testOptionsReturned = defaultOptions t + , testResult = result + } finish (Progress _ next) = next >>= finish - stubRunTests' g@(Group {}) = do - logs <- traverse stubRunTests' $ groupTests g - return $ GroupLogs (groupName g) logs + stubRunTests' g@(Group{}) = do + logs <- traverse stubRunTests' $ groupTests g + return $ GroupLogs (groupName g) logs stubRunTests' (ExtraOptions _ t) = stubRunTests' t maybeDefaultOption opt = - maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt + maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst -- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling -- Cabal process to read. stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO () stubWriteLog f n logs = do - let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f } - writeFile (logFile testLog) $ show testLog - when (suiteError logs) $ exitWith $ ExitFailure 2 - when (suiteFailed logs) $ exitWith $ ExitFailure 1 - exitSuccess + let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f} + writeFile (logFile testLog) $ show testLog + when (suiteError logs) $ exitWith $ ExitFailure 2 + when (suiteFailed logs) $ exitWith $ ExitFailure 1 + exitSuccess diff --git a/src/Distribution/Simple/Test/Log.hs b/src/Distribution/Simple/Test/Log.hs --- a/src/Distribution/Simple/Test/Log.hs +++ b/src/Distribution/Simple/Test/Log.hs @@ -2,49 +2,53 @@ {-# LANGUAGE RankNTypes #-} module Distribution.Simple.Test.Log - ( PackageLog(..) - , TestLogs(..) - , TestSuiteLog(..) - , countTestResults - , localPackageLog - , summarizePackage - , summarizeSuiteFinish, summarizeSuiteStart - , summarizeTest - , suiteError, suiteFailed, suitePassed - , testSuiteLogPath - ) where + ( PackageLog (..) + , TestLogs (..) + , TestSuiteLog (..) + , countTestResults + , localPackageLog + , summarizePackage + , summarizeSuiteFinish + , summarizeSuiteStart + , summarizeTest + , suiteError + , suiteFailed + , suitePassed + , testSuiteLogPath + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.Package -import Distribution.Types.UnqualComponentName import qualified Distribution.PackageDescription as PD +import Distribution.Pretty import Distribution.Simple.Compiler import Distribution.Simple.InstallDirs import qualified Distribution.Simple.LocalBuildInfo as LBI -import Distribution.Simple.Setup +import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never)) import Distribution.Simple.Utils import Distribution.System import Distribution.TestSuite +import Distribution.Types.UnqualComponentName import Distribution.Verbosity -import Distribution.Pretty import qualified Prelude (foldl1) -- | Logs all test results for a package, broken down first by test suite and -- then by test case. data PackageLog = PackageLog - { package :: PackageId - , compiler :: CompilerId - , platform :: Platform - , testSuites :: [TestSuiteLog] - } - deriving (Read, Show, Eq) + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) -- | A 'PackageLog' with package and platform information specified. localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog -localPackageLog pkg_descr lbi = PackageLog +localPackageLog pkg_descr lbi = + PackageLog { package = PD.package pkg_descr , compiler = compilerId $ LBI.compiler lbi , platform = LBI.hostPlatform lbi @@ -53,114 +57,137 @@ -- | Logs test suite results, itemized by test case. data TestSuiteLog = TestSuiteLog - { testSuiteName :: UnqualComponentName - , testLogs :: TestLogs - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) + { testSuiteName :: UnqualComponentName + , testLogs :: TestLogs + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) data TestLogs - = TestLog - { testName :: String - , testOptionsReturned :: Options - , testResult :: Result - } - | GroupLogs String [TestLogs] - deriving (Read, Show, Eq) + = TestLog + { testName :: String + , testOptionsReturned :: Options + , testResult :: Result + } + | GroupLogs String [TestLogs] + deriving (Read, Show, Eq) -- | Count the number of pass, fail, and error test results in a 'TestLogs' -- tree. -countTestResults :: TestLogs - -> (Int, Int, Int) -- ^ Passes, fails, and errors, - -- respectively. +countTestResults + :: TestLogs + -> (Int, Int, Int) + -- ^ Passes, fails, and errors, + -- respectively. countTestResults = go (0, 0, 0) where - go (p, f, e) (TestLog { testResult = r }) = - case r of - Pass -> (p + 1, f, e) - Fail _ -> (p, f + 1, e) - Error _ -> (p, f, e + 1) + go (p, f, e) (TestLog{testResult = r}) = + case r of + Pass -> (p + 1, f, e) + Fail _ -> (p, f + 1, e) + Error _ -> (p, f, e + 1) go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts -- | From a 'TestSuiteLog', determine if the test suite passed. suitePassed :: TestLogs -> Bool suitePassed l = - case countTestResults l of - (_, 0, 0) -> True - _ -> False + case countTestResults l of + (_, 0, 0) -> True + _ -> False -- | From a 'TestSuiteLog', determine if the test suite failed. suiteFailed :: TestLogs -> Bool suiteFailed l = - case countTestResults l of - (_, 0, _) -> False - _ -> True + case countTestResults l of + (_, 0, _) -> False + _ -> True -- | From a 'TestSuiteLog', determine if the test suite encountered errors. suiteError :: TestLogs -> Bool suiteError l = - case countTestResults l of - (_, _, 0) -> False - _ -> True + case countTestResults l of + (_, _, 0) -> False + _ -> True resultString :: TestLogs -> String -resultString l | suiteError l = "error" - | suiteFailed l = "fail" - | otherwise = "pass" +resultString l + | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" -testSuiteLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> String -- ^ test suite name - -> TestLogs -- ^ test suite results - -> FilePath +testSuiteLogPath + :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> String + -- ^ test suite name + -> TestLogs + -- ^ test suite results + -> FilePath testSuiteLogPath template pkg_descr lbi test_name result = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (LBI.localUnitId lbi) - (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) - ++ [ (TestSuiteNameVar, toPathTemplate test_name) - , (TestSuiteResultVar, toPathTemplate $ resultString result) - ] + fromPathTemplate $ substPathTemplate env template + where + env = + initialPathTemplateEnv + (PD.package pkg_descr) + (LBI.localUnitId lbi) + (compilerInfo $ LBI.compiler lbi) + (LBI.hostPlatform lbi) + ++ [ (TestSuiteNameVar, toPathTemplate test_name) + , (TestSuiteResultVar, toPathTemplate $ resultString result) + ] -- | Print a summary to the console after all test suites have been run -- indicating the number of successful test suites and cases. Returns 'True' if -- all test suites passed and 'False' otherwise. summarizePackage :: Verbosity -> PackageLog -> IO Bool summarizePackage verbosity packageLog = do - let counts = map (countTestResults . testLogs) $ testSuites packageLog - (passed, failed, errors) = Prelude.foldl1 addTriple counts - totalCases = passed + failed + errors - passedSuites = length - $ filter (suitePassed . testLogs) - $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passed ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites + let counts = map (countTestResults . testLogs) $ testSuites packageLog + (passed, failed, errors) = Prelude.foldl1 addTriple counts + totalCases = passed + failed + errors + passedSuites = + length $ + filter (suitePassed . testLogs) $ + testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ + show passedSuites + ++ " of " + ++ show totalSuites + ++ " test suites (" + ++ show passed + ++ " of " + ++ show totalCases + ++ " test cases) passed." + return $! passedSuites == totalSuites where addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2) -- | Print a summary of a single test case's result to the console, suppressing -- output for certain verbosity or test filter levels. summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO () -summarizeTest _ _ (GroupLogs {}) = return () +summarizeTest _ _ (GroupLogs{}) = return () summarizeTest verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ testName t - ++ ": " ++ show (testResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = testResult t /= Pass + when shouldPrint $ + notice verbosity $ + "Test case " + ++ testName t + ++ ": " + ++ show (testResult t) + where + shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = testResult t /= Pass -- | Print a summary of the test suite's results on the console, suppressing -- output for certain verbosity or test filter levels. summarizeSuiteFinish :: TestSuiteLog -> String -summarizeSuiteFinish testLog = unlines +summarizeSuiteFinish testLog = + unlines [ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr , "Test suite logged to: " ++ logFile testLog ] - where resStr = map toUpper (resultString $ testLogs testLog) + where + resStr = map toUpper (resultString $ testLogs testLog) summarizeSuiteStart :: String -> String summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" diff --git a/src/Distribution/Simple/UHC.hs b/src/Distribution/Simple/UHC.hs --- a/src/Distribution/Simple/UHC.hs +++ b/src/Distribution/Simple/UHC.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UHC -- Copyright : Andres Loeh 2009 @@ -16,57 +18,66 @@ -- Thanks to the authors of the other implementation-specific files, in -- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for -- inspiration on how to design this module. - -module Distribution.Simple.UHC ( - configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath +module Distribution.Simple.UHC + ( configure + , getInstalledPackages + , buildLib + , buildExe + , installLib + , registerPackage + , inplacePackageDbPath ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.InstalledPackageInfo import Distribution.Package hiding (installedUnitId) import Distribution.PackageDescription +import Distribution.Parsec +import Distribution.Pretty import Distribution.Simple.BuildPaths import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PackageIndex import Distribution.Simple.Program import Distribution.Simple.Utils -import Distribution.Pretty -import Distribution.Parsec +import Distribution.System import Distribution.Types.MungedPackageId +import Distribution.Utils.Path import Distribution.Verbosity import Distribution.Version -import Distribution.System import Language.Haskell.Extension -import Distribution.Utils.Path -import qualified Data.Map as Map ( empty ) +import qualified Data.Map as Map (empty) import System.Directory -import System.FilePath +import System.FilePath (pathSeparator) -- ----------------------------------------------------------------------------- -- Configuring -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb) -configure verbosity hcPath _hcPkgPath progdb = do - +configure + :: Verbosity + -> Maybe FilePath + -> ProgramDb + -> IO (Compiler, Maybe Platform, ProgramDb) +configure verbosity hcPath progdb = do (_uhcProg, uhcVersion, progdb') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (mkVersion [1,0,2])) - (userMaybeSpecifyPath "uhc" hcPath progdb) + requireProgramVersion + verbosity + uhcProgram + (orLaterVersion (mkVersion [1, 0, 2])) + (userMaybeSpecifyPath "uhc" hcPath progdb) - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerAbiTag = NoAbiTag, - compilerCompat = [], - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions, - compilerProperties = Map.empty - } + let comp = + Compiler + { compilerId = CompilerId UHC uhcVersion + , compilerAbiTag = NoAbiTag + , compilerCompat = [] + , compilerLanguages = uhcLanguages + , compilerExtensions = uhcLanguageExtensions + , compilerProperties = Map.empty + } compPlatform = Nothing return (comp, compPlatform, progdb') @@ -76,64 +87,84 @@ -- | The flags for the supported extensions. uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)] uhcLanguageExtensions = - let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), - (DisableExtension f, disable)] - alwaysOn = (Nothing, Nothing{- wrong -}) - in concatMap doFlag - [(CPP, (Just "--cpp", Nothing{- wrong -})), - (PolymorphicComponents, alwaysOn), - (ExistentialQuantification, alwaysOn), - (ForeignFunctionInterface, alwaysOn), - (UndecidableInstances, alwaysOn), - (MultiParamTypeClasses, alwaysOn), - (Rank2Types, alwaysOn), - (PatternSignatures, alwaysOn), - (EmptyDataDecls, alwaysOn), - (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})), - (TypeOperators, alwaysOn), - (OverlappingInstances, alwaysOn), - (FlexibleInstances, alwaysOn)] + let doFlag (f, (enable, disable)) = + [ (EnableExtension f, enable) + , (DisableExtension f, disable) + ] + alwaysOn = (Nothing, Nothing {- wrong -}) + in concatMap + doFlag + [ (CPP, (Just "--cpp", Nothing {- wrong -})) + , (PolymorphicComponents, alwaysOn) + , (ExistentialQuantification, alwaysOn) + , (ForeignFunctionInterface, alwaysOn) + , (UndecidableInstances, alwaysOn) + , (MultiParamTypeClasses, alwaysOn) + , (Rank2Types, alwaysOn) + , (PatternSignatures, alwaysOn) + , (EmptyDataDecls, alwaysOn) + , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -})) + , (TypeOperators, alwaysOn) + , (OverlappingInstances, alwaysOn) + , (FlexibleInstances, alwaysOn) + ] -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb - -> IO InstalledPackageIndex -getInstalledPackages verbosity comp packagedbs progdb = do +getInstalledPackages + :: Verbosity + -> Compiler + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBStackX (SymbolicPath from (Dir PkgDB)) + -> ProgramDb + -> IO InstalledPackageIndex +getInstalledPackages verbosity comp mbWorkDir packagedbs progdb = do let compilerid = compilerId comp systemPkgDir <- getGlobalPackageDir verbosity progdb - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir mbWorkDir) packagedbs) -- putStrLn $ "pkgdirs: " ++ show pkgDirs - pkgs <- liftM (map addBuiltinVersions . concat) $ - traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) - pkgDirs + pkgs <- + liftM (map addBuiltinVersions . concat) $ + traverse + (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d)) + pkgDirs -- putStrLn $ "pkgs: " ++ show pkgs let iPkgs = map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs + concatMap parsePackage $ + pkgs -- putStrLn $ "installed pkgs: " ++ show iPkgs return (fromList iPkgs) getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath getGlobalPackageDir verbosity progdb = do - output <- getDbProgramOutput verbosity - uhcProgram progdb ["--meta-pkgdir-system"] - -- we need to trim because pkgdir contains an extra newline at the end - let pkgdir = trimEnd output - return pkgdir + output <- + getDbProgramOutput + verbosity + uhcProgram + progdb + ["--meta-pkgdir-system"] + -- we need to trim because pkgdir contains an extra newline at the end + let pkgdir = trimEnd output + return pkgdir where - trimEnd = reverse . dropWhile isSpace . reverse + trimEnd = dropWhileEnd isSpace getUserPackageDir :: IO FilePath getUserPackageDir = do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] -packageDbPaths user system db = +packageDbPaths + :: FilePath + -> FilePath + -> Maybe (SymbolicPath CWD (Dir from)) + -> PackageDBX (SymbolicPath from (Dir PkgDB)) + -> [FilePath] +packageDbPaths user system mbWorkDir db = case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] + GlobalPackageDB -> [system] + UserPackageDB -> [user] + SpecificPackageDB path -> [interpretSymbolicPath mbWorkDir path] -- | Hack to add version numbers to UHC-built-in packages. This should sooner or -- later be fixed on the UHC side. @@ -143,7 +174,7 @@ addBuiltinVersions "base" = "base-3.0" addBuiltinVersions "array" = "array-0.2" -} -addBuiltinVersions xs = xs +addBuiltinVersions xs = xs -- | Name of the installed package config file. installedPkgConfig :: String @@ -153,144 +184,194 @@ -- looking only for the presence of an installed package configuration. -- TODO: Actually make use of the information provided in the file. isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) parsePackage :: String -> [PackageId] -parsePackage = toList . simpleParsec +parsePackage = toList . simpleParsec -- | Create a trivial package info from a directory name. mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedUnitId = mkLegacyUnitId p, - sourcePackageId = p } - +mkInstalledPackageInfo p = + emptyInstalledPackageInfo + { installedUnitId = mkLegacyUnitId p + , sourcePackageId = p + } -- ----------------------------------------------------------------------------- -- Building -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () +buildLib + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Library + -> ComponentLocalBuildInfo + -> IO () buildLib verbosity pkg_descr lbi lib clbi = do - systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map prettyShow (allLibModules lib clbi)) + userPkgDir <- getUserPackageDir + let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) + let uhcArgs = + -- set package name + ["--pkg-build=" ++ prettyShow (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (libBuildInfo lib) + clbi + (buildDir lbi) + verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map + (map (\c -> if c == '.' then pathSeparator else c)) + (map prettyShow (allLibModules lib clbi)) runUhcProg uhcArgs return () -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe + :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> Executable + -> ComponentLocalBuildInfo + -> IO () buildExe verbosity _pkg_descr lbi exe clbi = do systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi) - userPkgDir <- getUserPackageDir - let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi prettyShow (exeName exe)] - -- main source module - ++ [modulePath exe] + userPkgDir <- getUserPackageDir + let mbWorkDir = mbWorkDirLBI lbi + srcMainPath <- findFileCwd verbosity mbWorkDir (hsSourceDirs $ buildInfo exe) (modulePath exe) + let runUhcProg = runDbProgramCwd verbosity (mbWorkDirLBI lbi) uhcProgram (withPrograms lbi) + u = interpretSymbolicPathCWD + uhcArgs = + -- common flags lib/exe + constructUHCCmdLine + userPkgDir + systemPkgDir + lbi + (buildInfo exe) + clbi + (buildDir lbi) + verbosity + -- output file + ++ ["--output", u $ buildDir lbi makeRelativePathEx (prettyShow (exeName exe))] + -- main source module + ++ [u $ srcMainPath] runUhcProg uhcArgs -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] +constructUHCCmdLine + :: FilePath + -> FilePath + -> LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg (Dir Build) + -> Verbosity + -> [String] constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenComponentModulesDir lbi clbi] - ++ ["-i" ++ autogenPackageModulesDir lbi] - -- cpp options - ++ ["--optP=" ++ opt | opt <- cppOptions bi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) + -- verbosity + ( if verbosity >= deafening + then ["-v4"] + else + if verbosity >= normal + then [] + else ["-v0"] + ) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi] + -- search paths + ++ ["-i" ++ u odir] + ++ ["-i" ++ u l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ u (autogenComponentModulesDir lbi clbi)] + ++ ["-i" ++ u (autogenPackageModulesDir lbi)] + -- cpp options + ++ ["--optP=" ++ opt | opt <- cppOptions bi] + -- output path + ++ ["--odir=" ++ u odir] + -- optimization + ++ ( case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"] + ) + where + u = interpretSymbolicPathCWD -- See Note [Symbolic paths] in Distribution.Utils.Path uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) +uhcPackageDbOptions user system db = + map + (\x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system Nothing) db) -- ----------------------------------------------------------------------------- -- Installation -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO () +installLib + :: Verbosity + -> LocalBuildInfo + -> FilePath + -> FilePath + -> FilePath + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> IO () installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir prettyShow (packageId pkg)) targetDir -- currently hard-coded UHC code generator and variant to use uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" +uhcTarget = "bc" uhcTargetVariant = "plain" -- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant -- ----------------------------------------------------------------------------- -- Registering registerPackage :: Verbosity + -> Maybe (SymbolicPath CWD (Dir from)) -> Compiler -> ProgramDb - -> PackageDBStack + -> PackageDBStackS from -> InstalledPackageInfo -> IO () -registerPackage verbosity comp progdb packageDbs installedPkgInfo = do - dbdir <- case registrationPackageDB packageDbs of - GlobalPackageDB -> getGlobalPackageDir verbosity progdb - UserPackageDB -> getUserPackageDir - SpecificPackageDB dir -> return dir - let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) +registerPackage verbosity mbWorkDir comp progdb packageDbs installedPkgInfo = do + dbdir <- case registrationPackageDB packageDbs of + GlobalPackageDB -> getGlobalPackageDir verbosity progdb + UserPackageDB -> getUserPackageDir + SpecificPackageDB dir -> return (interpretSymbolicPath mbWorkDir dir) + let pkgdir = dbdir uhcPackageDir (prettyShow pkgid) (prettyShow compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File + (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) where - pkgid = sourcePackageId installedPkgInfo + pkgid = sourcePackageId installedPkgInfo compilerid = compilerId comp -inplacePackageDbPath :: LocalBuildInfo -> FilePath -inplacePackageDbPath lbi = buildDir lbi +inplacePackageDbPath :: LocalBuildInfo -> SymbolicPath Pkg (Dir PkgDB) +inplacePackageDbPath lbi = coerceSymbolicPath $ buildDir lbi diff --git a/src/Distribution/Simple/UserHooks.hs b/src/Distribution/Simple/UserHooks.hs --- a/src/Distribution/Simple/UserHooks.hs +++ b/src/Distribution/Simple/UserHooks.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.Simple.UserHooks -- Copyright : Isaac Jones 2003-2005 @@ -25,21 +26,21 @@ -- pass any extra parameters to most of the functions that implement the -- various phases because it would involve changing the types of the -- corresponding hook. At some point it will have to be replaced. - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, +module Distribution.Simple.UserHooks + ( UserHooks (..) + , Args + , emptyUserHooks ) where +import Distribution.Compat.Prelude hiding (getContents, putStr) import Prelude () -import Distribution.Compat.Prelude import Distribution.PackageDescription -import Distribution.Simple.Program import Distribution.Simple.Command +import Distribution.Simple.LocalBuildInfo import Distribution.Simple.PreProcess +import Distribution.Simple.Program import Distribution.Simple.Setup -import Distribution.Simple.LocalBuildInfo type Args = [String] @@ -49,149 +50,137 @@ -- * WARNING: The hooks interface is under rather constant flux as we try to -- understand users needs. Setup files that depend on this interface may -- break in future releases. -data UserHooks = UserHooks { - - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before repl command. Second arg indicates verbosity level. - preRepl :: Args -> ReplFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during interpretation. - replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (), - -- |Hook to run after repl command. Second arg indicates verbosity level. - postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during unregistration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before test command. - preTest :: Args -> TestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during test. - testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before bench command. - preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during bench. - benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (), - -- |Hook to run after bench command. - postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () +data UserHooks = UserHooks + { readDesc :: IO (Maybe GenericPackageDescription) + -- ^ Read the description file + , hookedPreProcessors :: [PPSuffixHandler] + -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + , hookedPrograms :: [Program] + -- ^ These programs are detected at configure time. Arguments for them are + -- added to the configure command. + , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo + -- ^ Hook to run before configure command + , confHook + :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags + -> IO LocalBuildInfo + -- ^ Over-ride this hook to get different behavior during configure. + , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after configure command + , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo + -- ^ Hook to run before build command. Second arg indicates verbosity level. + , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () + -- ^ Over-ride this hook to get different behavior during build. + , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after build command. Second arg indicates verbosity level. + , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo + -- ^ Hook to run before repl command. Second arg indicates verbosity level. + , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO () + -- ^ Over-ride this hook to get different behavior during interpretation. + , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after repl command. Second arg indicates verbosity level. + , preClean :: Args -> CleanFlags -> IO HookedBuildInfo + -- ^ Hook to run before clean command. Second arg indicates verbosity level. + , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO () + -- ^ Over-ride this hook to get different behavior during clean. + , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO () + -- ^ Hook to run after clean command. Second arg indicates verbosity level. + , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo + -- ^ Hook to run before copy command + , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () + -- ^ Over-ride this hook to get different behavior during copy. + , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after copy command + , preInst :: Args -> InstallFlags -> IO HookedBuildInfo + -- ^ Hook to run before install command + , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () + -- ^ Over-ride this hook to get different behavior during install. + , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before register command + , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during registration. + , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after register command + , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo + -- ^ Hook to run before unregister command + , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () + -- ^ Over-ride this hook to get different behavior during unregistration. + , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after unregister command + , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo + -- ^ Hook to run before hscolour command. Second arg indicates verbosity level. + , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO () + -- ^ Over-ride this hook to get different behavior during hscolour. + , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after hscolour command. Second arg indicates verbosity level. + , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo + -- ^ Hook to run before haddock command. Second arg indicates verbosity level. + , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO () + -- ^ Over-ride this hook to get different behavior during haddock. + , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after haddock command. Second arg indicates verbosity level. + , preTest :: Args -> TestFlags -> IO HookedBuildInfo + -- ^ Hook to run before test command. + , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO () + -- ^ Over-ride this hook to get different behavior during test. + , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after test command. + , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo + -- ^ Hook to run before bench command. + , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO () + -- ^ Over-ride this hook to get different behavior during bench. + , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO () + -- ^ Hook to run after bench command. } --- |Empty 'UserHooks' which do nothing. +-- | Empty 'UserHooks' which do nothing. emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn', - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn', - buildHook = ru, - postBuild = ru, - preRepl = \_ _ -> return emptyHookedBuildInfo, - replHook = \_ _ _ _ _ -> return (), - postRepl = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn', - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preReg = rn', - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn', - haddockHook = ru, - postHaddock = ru, - preTest = rn', - testHook = \_ -> ru, - postTest = ru, - preBench = rn', - benchHook = \_ -> ru, - postBench = ru +emptyUserHooks = + UserHooks + { readDesc = return Nothing + , hookedPreProcessors = [] + , hookedPrograms = [] + , preConf = rn' + , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")) + , postConf = ru + , preBuild = rn' + , buildHook = ru + , postBuild = ru + , preRepl = \_ _ -> return emptyHookedBuildInfo + , replHook = \_ _ _ _ _ -> return () + , postRepl = ru + , preClean = rn + , cleanHook = ru + , postClean = ru + , preCopy = rn' + , copyHook = ru + , postCopy = ru + , preInst = rn + , instHook = ru + , postInst = ru + , preReg = rn' + , regHook = ru + , postReg = ru + , preUnreg = rn + , unregHook = ru + , postUnreg = ru + , preHscolour = rn + , hscolourHook = ru + , postHscolour = ru + , preHaddock = rn' + , haddockHook = ru + , postHaddock = ru + , preTest = rn' + , testHook = \_ -> ru + , postTest = ru + , preBench = rn' + , benchHook = \_ -> ru + , postBench = ru } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - rn' _ _ = return emptyHookedBuildInfo - ru _ _ _ _ = return () + where + rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + rn' _ _ = return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/src/Distribution/Simple/Utils.hs b/src/Distribution/Simple/Utils.hs --- a/src/Distribution/Simple/Utils.hs +++ b/src/Distribution/Simple/Utils.hs @@ -1,1609 +1,2072 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Simple.Utils ( - cabalVersion, - - -- * logging and errors - dieNoVerbosity, - die', dieWithLocation', - dieNoWrap, - topHandler, topHandlerWith, - warn, - notice, noticeNoWrap, noticeDoc, - setupMessage, - info, infoNoWrap, - debug, debugNoWrap, - chattyTry, - annotateIO, - printRawCommandAndArgs, printRawCommandAndArgsAndEnv, - withOutputMarker, - - -- * exceptions - handleDoesNotExist, - - -- * running programs - rawSystemExit, - rawSystemExitCode, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - rawSystemIOWithEnv, - rawSystemIOWithEnvAndAction, - createProcessWithEnv, - maybeExit, - xargs, - findProgramVersion, - - -- ** 'IOData' re-export - -- - -- These types are re-exported from - -- "Distribution.Utils.IOData" for convience as they're - -- exposed in the API of 'rawSystemStdInOut' - IOData(..), - KnownIODataMode (..), - IODataMode (..), - - -- * copying files - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyFiles, - copyFileTo, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installMaybeExecutableFile, - installOrdinaryFiles, - installExecutableFiles, - installMaybeExecutableFiles, - installDirectoryContents, - copyDirectoryRecursive, - - -- * File permissions - doesExecutableExist, - setFileOrdinary, - setFileExecutable, - - -- * file names - currentDir, - shortRelativePath, - dropExeExtension, - exeExtensions, - - -- * finding files - findFileEx, - findFileCwd, - findFirstFile, - findFileWithExtension, - findFileCwdWithExtension, - findFileWithExtension', - findAllFilesWithExtension, - findAllFilesCwdWithExtension, - findModuleFileEx, - findModuleFilesEx, - getDirectoryContentsRecursive, - - -- * environment variables - isInSearchPath, - addLibraryPath, - - -- * modification time - moreRecentFile, - existsAndIsMoreRecentThan, - - -- * temp files and dirs - TempFileOptions(..), defaultTempFileOptions, - withTempFile, withTempFileEx, - withTempDirectory, withTempDirectoryEx, - createTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - findPackageDescCwd, - tryFindPackageDesc, - tryFindPackageDescCwd, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFileEx, - rewriteFileLBS, - - -- * Unicode - fromUTF8BS, - fromUTF8LBS, - toUTF8BS, - toUTF8LBS, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * BOM - ignoreBOM, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - - -- * Deprecated functions - findFile, - findModuleFile, - findModuleFiles, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic -import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..)) -import qualified Distribution.Utils.IOData as IOData -import Distribution.ModuleName as ModuleName -import Distribution.System -import Distribution.Version -import Distribution.Compat.Async -import Distribution.Compat.CopyFile -import Distribution.Compat.Internal.TempFile -import Distribution.Compat.FilePath as FilePath -import Distribution.Compat.Stack -import Distribution.Verbosity -import Distribution.Types.PackageId - -#if __GLASGOW_HASKELL__ < 711 -#ifdef VERSION_base -#define BOOTSTRAPPED_CABAL 1 -#endif -#else -#ifdef CURRENT_PACKAGE_KEY -#define BOOTSTRAPPED_CABAL 1 -#endif -#endif - -#ifdef BOOTSTRAPPED_CABAL -import qualified Paths_Cabal (version) -#endif - -import Distribution.Pretty -import Distribution.Parsec - -import Data.Typeable - ( cast ) -import qualified Data.ByteString.Lazy as BS - -import System.Directory - ( Permissions(executable), getDirectoryContents, getPermissions - , doesDirectoryExist, doesFileExist, removeFile - , getModificationTime, createDirectory, removeDirectoryRecursive ) -import System.Environment - ( getProgName ) -import System.FilePath as FilePath - ( normalise, (), (<.>) - , getSearchPath, joinPath, takeDirectory, splitExtension - , splitDirectories, searchPathSeparator ) -import System.IO - ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hSetBuffering, BufferMode(..), hPutStrLn ) -import System.IO.Error -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Foreign.C.Error (Errno (..), ePIPE) -import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) -import Numeric (showFFloat) -import Distribution.Compat.Process (createProcess, rawSystem, runInteractiveProcess) -import System.Process - ( ProcessHandle - , showCommandForUser, waitForProcess) -import qualified System.Process as Process -import qualified GHC.IO.Exception as GHC - -import qualified Text.PrettyPrint as Disp - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#if defined(BOOTSTRAPPED_CABAL) -cabalVersion = mkVersion' Paths_Cabal.version -#elif defined(CABAL_VERSION) -cabalVersion = mkVersion [CABAL_VERSION] -#else -cabalVersion = mkVersion [3,0] --used when bootstrapping -#endif - --- ---------------------------------------------------------------------------- --- Exception and logging utils - --- Cabal's logging infrastructure has a few constraints: --- --- * We must make all logging formatting and emissions decisions based --- on the 'Verbosity' parameter, which is the only parameter that is --- plumbed to enough call-sites to actually be used for this matter. --- (One of Cabal's "big mistakes" is to have never have defined a --- monad of its own.) --- --- * When we 'die', we must raise an IOError. This a backwards --- compatibility consideration, because that's what we've raised --- previously, and if we change to any other exception type, --- exception handlers which match on IOError will no longer work. --- One case where it is known we rely on IOError being catchable --- is 'readPkgConfigDb' in cabal-install; there may be other --- user code that also assumes this. --- --- * The 'topHandler' does not know what 'Verbosity' is, because --- it gets called before we've done command line parsing (where --- the 'Verbosity' parameter would come from). --- --- This leads to two big architectural choices: --- --- * Although naively we might imagine 'Verbosity' to be a simple --- enumeration type, actually it is a full-on abstract data type --- that may contain arbitrarily complex information. At the --- moment, it is fully representable as a string, but we might --- eventually also use verbosity to let users register their --- own logging handler. --- --- * When we call 'die', we perform all the formatting and addition --- of extra information we need, and then ship this in the IOError --- to the top-level handler. Here are alternate designs that --- don't work: --- --- a) Ship the unformatted info to the handler. This doesn't --- work because at the point the handler gets the message, --- we've lost call stacks, and even if we did, we don't have access --- to 'Verbosity' to decide whether or not to render it. --- --- b) Print the information at the 'die' site, then raise an --- error. This means that if the exception is subsequently --- caught by a handler, we will still have emitted the output, --- which is not the correct behavior. --- --- For the top-level handler to "know" that an error message --- contains one of these fully formatted packets, we set a sentinel --- in one of IOError's extra fields. This is handled by --- 'ioeSetVerbatim' and 'ioeGetVerbatim'. --- - -dieNoVerbosity :: String -> IO a -dieNoVerbosity msg - = ioError (userError msg) - where - _ = callStack -- TODO: Attach CallStack to exception - --- | Tag an 'IOError' whose error string should be output to the screen --- verbatim. -ioeSetVerbatim :: IOError -> IOError -ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" - --- | Check if an 'IOError' should be output verbatim to screen. -ioeGetVerbatim :: IOError -> Bool -ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" - --- | Create a 'userError' whose error text will be output verbatim -verbatimUserError :: String -> IOError -verbatimUserError = ioeSetVerbatim . userError - -dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a -dieWithLocation' verbosity filename mb_lineno msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ - filename ++ (case mb_lineno of - Just lineno -> ":" ++ show lineno - Nothing -> "") ++ - ": " ++ msg - -die' :: Verbosity -> String -> IO a -die' verbosity msg = withFrozenCallStack $ do - ts <- getPOSIXTime - pname <- getProgName - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - . wrapTextVerbosity verbosity - $ pname ++ ": " ++ msg - -dieNoWrap :: Verbosity -> String -> IO a -dieNoWrap verbosity msg = withFrozenCallStack $ do - -- TODO: should this have program name or not? - ts <- getPOSIXTime - ioError . verbatimUserError - . withMetadata ts AlwaysMark VerboseTrace verbosity - $ msg - --- | Given a block of IO code that may raise an exception, annotate --- it with the metadata from the current scope. Use this as close --- to external code that raises IO exceptions as possible, since --- this function unconditionally wraps the error message with a trace --- (so it is NOT idempotent.) -annotateIO :: Verbosity -> IO a -> IO a -annotateIO verbosity act = do - ts <- getPOSIXTime - modifyIOError (f ts) act - where - f ts ioe = ioeSetErrorString ioe - . withMetadata ts NeverMark VerboseTrace verbosity - $ ioeGetErrorString ioe - - -{-# NOINLINE topHandlerWith #-} -topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a -topHandlerWith cont prog = do - -- By default, stderr to a terminal device is NoBuffering. But this - -- is *really slow* - hSetBuffering stderr LineBuffering - Exception.catches prog [ - Exception.Handler rethrowAsyncExceptions - , Exception.Handler rethrowExitStatus - , Exception.Handler handle - ] - where - -- Let async exceptions rise to the top for the default top-handler - rethrowAsyncExceptions :: Exception.AsyncException -> IO a - rethrowAsyncExceptions a = throwIO a - - -- ExitCode gets thrown asynchronously too, and we don't want to print it - rethrowExitStatus :: ExitCode -> IO a - rethrowExitStatus = throwIO - - -- Print all other exceptions - handle :: Exception.SomeException -> IO a - handle se = do - hFlush stdout - pname <- getProgName - hPutStr stderr (message pname se) - cont se - - message :: String -> Exception.SomeException -> String - message pname (Exception.SomeException se) = - case cast se :: Maybe Exception.IOException of - Just ioe - | ioeGetVerbatim ioe -> - -- Use the message verbatim - ioeGetErrorString ioe ++ "\n" - | isUserError ioe -> - let file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " - location = case ioeGetLocation ioe of - l@(n:_) | isDigit n -> ':' : l - _ -> "" - detail = ioeGetErrorString ioe - in wrapText (pname ++ ": " ++ file ++ detail) - _ -> - displaySomeException se ++ "\n" - --- | BC wrapper around 'Exception.displayException'. -displaySomeException :: Exception.Exception e => e -> String -displaySomeException se = -#if __GLASGOW_HASKELL__ < 710 - show se -#else - Exception.displayException se -#endif - -topHandler :: IO a -> IO a -topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog - -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - ts <- getPOSIXTime - hFlush stdout - hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity - $ "Warning: " ++ msg - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - --- | Display a message at 'normal' verbosity level, but without --- wrapping. --- -noticeNoWrap :: Verbosity -> String -> IO () -noticeNoWrap verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg - --- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity --- level. Use this if you need fancy formatting. --- -noticeDoc :: Verbosity -> Disp.Doc -> IO () -noticeDoc verbosity msg = withFrozenCallStack $ do - when (verbosity >= normal) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NormalMark FlagTrace verbosity - $ Disp.renderStyle defaultStyle - $ msg - --- | Display a "setup status message". Prefer using setupMessage' --- if possible. --- -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = withFrozenCallStack $ do - noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...") - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -infoNoWrap :: Verbosity -> String -> IO () -infoNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | A variant of 'debug' that doesn't perform the automatic line --- wrapping. Produces better output in some cases. -debugNoWrap :: Verbosity -> String -> IO () -debugNoWrap verbosity msg = withFrozenCallStack $ - when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity - ts <- getPOSIXTime - hPutStr h - $ withMetadata ts NeverMark FlagTrace verbosity - $ msg - -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception - --- | Run an IO computation, returning @e@ if it raises a "file --- does not exist" error. -handleDoesNotExist :: a -> IO a -> IO a -handleDoesNotExist e = - Exception.handleJust - (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) - (\_ -> return e) - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text unless the @+nowrap@ verbosity flag is active -wrapTextVerbosity :: Verbosity -> String -> String -wrapTextVerbosity verb - | isVerboseNoWrap verb = withTrailingNewline - | otherwise = withTrailingNewline . wrapText - - --- | Prepends a timestamp if @+timestamp@ verbosity flag is set --- --- This is used by 'withMetadata' --- -withTimestamp :: Verbosity -> POSIXTime -> String -> String -withTimestamp v ts msg - | isVerboseTimestamp v = msg' - | otherwise = msg -- no-op - where - msg' = case lines msg of - [] -> tsstr "\n" - l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest) - - -- format timestamp to be prepended to first line with msec precision - tsstr = showFFloat (Just 3) (realToFrac ts :: Double) - - -- continuation prefix for subsequent lines of msg - contpfx = replicate (length (tsstr " ")) ' ' - --- | Wrap output with a marker if @+markoutput@ verbosity flag is set. --- --- NB: Why is markoutput done with start/end markers, and not prefixes? --- Markers are more convenient to add (if we want to add prefixes, --- we have to 'lines' and then 'map'; here's it's just some --- concatenates). Note that even in the prefix case, we can't --- guarantee that the markers are unambiguous, because some of --- Cabal's output comes straight from external programs, where --- we don't have the ability to interpose on the output. --- --- This is used by 'withMetadata' --- -withOutputMarker :: Verbosity -> String -> String -withOutputMarker v xs | not (isVerboseMarkOutput v) = xs -withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly -withOutputMarker _ xs = - "-----BEGIN CABAL OUTPUT-----\n" ++ - withTrailingNewline xs ++ - "-----END CABAL OUTPUT-----\n" - --- | Append a trailing newline to a string if it does not --- already have a trailing newline. --- -withTrailingNewline :: String -> String -withTrailingNewline "" = "" -withTrailingNewline (x:xs) = x : go x xs - where - go _ (c:cs) = c : go c cs - go '\n' "" = "" - go _ "" = "\n" - --- | Prepend a call-site and/or call-stack based on Verbosity --- -withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) -withCallStackPrefix tracer verbosity s = withFrozenCallStack $ - (if isVerboseCallSite verbosity - then parentSrcLocPrefix ++ - -- Hack: need a newline before starting output marker :( - if isVerboseMarkOutput verbosity - then "\n" - else "" - else "") ++ - (case traceWhen verbosity tracer of - Just pre -> pre ++ prettyCallStack callStack ++ "\n" - Nothing -> "") ++ - s - --- | When should we emit the call stack? We always emit --- for internal errors, emit the trace for errors when we --- are in verbose mode, and otherwise only emit it if --- explicitly asked for using the @+callstack@ verbosity --- flag. (At the moment, 'AlwaysTrace' is not used. --- -data TraceWhen - = AlwaysTrace - | VerboseTrace - | FlagTrace - deriving (Eq) - --- | Determine if we should emit a call stack. --- If we trace, it also emits any prefix we should append. -traceWhen :: Verbosity -> TraceWhen -> Maybe String -traceWhen _ AlwaysTrace = Just "" -traceWhen v VerboseTrace | v >= verbose = Just "" -traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" -traceWhen _ _ = Nothing - --- | When should we output the marker? Things like 'die' --- always get marked, but a 'NormalMark' will only be --- output if we're not a quiet verbosity. --- -data MarkWhen = AlwaysMark | NormalMark | NeverMark - --- | Add all necessary metadata to a logging message --- -withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) -withMetadata ts marker tracer verbosity x = withFrozenCallStack $ - -- NB: order matters. Output marker first because we - -- don't want to capture call stacks. - withTrailingNewline - . withCallStackPrefix tracer verbosity - . (case marker of - AlwaysMark -> withOutputMarker verbosity - NormalMark | not (isVerboseQuiet verbosity) - -> withOutputMarker verbosity - | otherwise - -> id - NeverMark -> id) - -- Clear out any existing markers - . clearMarkers - . withTimestamp verbosity ts - $ x - -clearMarkers :: String -> String -clearMarkers s = unlines . filter isMarker $ lines s - where - isMarker "-----BEGIN CABAL OUTPUT-----" = False - isMarker "-----END CABAL OUTPUT-----" = False - isMarker _ = True - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - - - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args = withFrozenCallStack $ - printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing - -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath - -> Maybe [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args mcwd menv = do - case menv of - Just env -> debugNoWrap verbosity ("Environment: " ++ show env) - Nothing -> return () - case mcwd of - Just cwd -> debugNoWrap verbosity ("Working directory: " ++ show cwd) - Nothing -> return () - infoNoWrap verbosity (showCommandForUser path args) - --- Exit with the same exit code if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - -rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode -rawSystemExitCode verbosity path args = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args Nothing (Just env) - hFlush stdout - (_,_,_,ph) <- createProcess $ - (Process.proc path args) { Process.env = (Just env) -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version - , Process.delegate_ctlc = True -#endif -#endif - } - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- Closes the passed in handles before returning. -rawSystemIOWithEnv :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO ExitCode -rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv - (mbToStd inp) (mbToStd out) (mbToStd err) - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return exitcode - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle - -rawSystemIOWithEnvAndAction - :: Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'. - -> Maybe Handle -- ^ stdin - -> Maybe Handle -- ^ stdout - -> Maybe Handle -- ^ stderr - -> IO (ExitCode, a) -rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do - (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv - (mbToStd inp) (mbToStd out) (mbToStd err) - a <- action - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - return (exitcode, a) - where - mbToStd :: Maybe Handle -> Process.StdStream - mbToStd = maybe Process.Inherit Process.UseHandle - -createProcessWithEnv :: - Verbosity - -> FilePath - -> [String] - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Process.StdStream -- ^ stdin - -> Process.StdStream -- ^ stdout - -> Process.StdStream -- ^ stderr - -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) - -- ^ Any handles created for stdin, stdout, or stderr - -- with 'CreateProcess', and a handle to the process. -createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - printRawCommandAndArgsAndEnv verbosity path args mcwd menv - hFlush stdout - (inp', out', err', ph) <- createProcess $ - (Process.proc path args) { - Process.cwd = mcwd - , Process.env = menv - , Process.std_in = inp - , Process.std_out = out - , Process.std_err = err -#ifdef MIN_VERSION_process -#if MIN_VERSION_process(1,2,0) --- delegate_ctlc has been added in process 1.2, and we still want to be able to --- bootstrap GHC on systems not having that version - , Process.delegate_ctlc = True -#endif -#endif - } - return (inp', out', err', ph) - --- | Run a command and return its output. --- --- The output is assumed to be text in the locale encoding. --- -rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode -rawSystemStdout verbosity path args = withFrozenCallStack $ do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode) - when (exitCode /= ExitSuccess) $ - die' verbosity errors - return output - --- | Run a command and return its output, errors and exit status. Optionally --- also supply some input. Also provides control over whether the binary/text --- mode of the input and output. --- -rawSystemStdInOut :: KnownIODataMode mode - => Verbosity - -> FilePath -- ^ Program location - -> [String] -- ^ Arguments - -> Maybe FilePath -- ^ New working dir or inherit - -> Maybe [(String, String)] -- ^ New environment or inherit - -> Maybe IOData -- ^ input text and binary mode - -> IODataMode mode -- ^ iodata mode, acts as proxy - -> IO (mode, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do - printRawCommandAndArgs verbosity path args - - Exception.bracket - (runInteractiveProcess path args mcwd menv) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(inh,outh,errh,pid) -> do - - -- output mode depends on what the caller wants - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do - -- push all the input, if any - ignoreSigPipe $ case input of - Nothing -> hClose inh - Just inputData -> IOData.hPutContents inh inputData - - -- wait for both to finish - mberr1 <- waitCatch outA - mberr2 <- waitCatch errA - - -- wait for the program to terminate - exitcode <- waitForProcess pid - - -- get the stderr, so it can be added to error message - err <- reportOutputIOError mberr2 - - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - ++ case input of - Nothing -> "" - Just d | IOData.null d -> "" - Just (IODataText inp) -> "\nstdin input:\n" ++ inp - Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp - - -- Check if we hit an exception while consuming the output - -- (e.g. a text decoding error) - out <- reportOutputIOError mberr1 - - return (out, err, exitcode) - where - reportOutputIOError :: Either Exception.SomeException a -> IO a - reportOutputIOError (Right x) = return x - reportOutputIOError (Left exc) = case fromException exc of - Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) - Nothing -> throwIO exc - - ignoreSigPipe :: IO () -> IO () - ignoreSigPipe = Exception.handle $ \e -> case e of - GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") - let version :: Maybe Version - version = simpleParsec (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v - return version - - --- | Like the Unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - - -{-# DEPRECATED findFile "Use findFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile = findFileEx normal - --- | Find a file by looking in a search path. The file path must match exactly. --- --- @since 3.4.0.0 -findFileCwd - :: Verbosity - -> FilePath -- ^ cwd - -> [FilePath] -- ^ relative search location - -> FilePath -- ^ File Name - -> IO FilePath -findFileCwd verbosity cwd searchPath fileName = - findFirstFile (cwd ) - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFileEx :: Verbosity - -> [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFileEx verbosity searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findFileCwdWithExtension - :: FilePath - -> [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileCwdWithExtension cwd extensions searchPath baseName = - findFirstFile (cwd ) - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | @since 3.4.0.0 -findAllFilesCwdWithExtension - :: FilePath -- ^ cwd - -> [String] -- ^ extensions - -> [FilePath] -- ^ relative search locations - -> FilePath -- ^ basename - -> IO [FilePath] -findAllFilesCwdWithExtension cwd extensions searchPath basename = - findAllFiles (cwd ) - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - -findAllFilesWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO [FilePath] -findAllFilesWithExtension extensions searchPath basename = - findAllFiles id - [ path basename <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFileWithExtension' but returns which element of the search path --- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - -findAllFiles :: (a -> FilePath) -> [a] -> IO [a] -findAllFiles file = filterM (doesFileExist . file) - - -{-# DEPRECATED findModuleFiles "Use findModuleFilesEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFiles = findModuleFilesEx normal - --- | Finds the files corresponding to a list of Haskell module names. --- --- As 'findModuleFile' but for a list of module names. --- -findModuleFilesEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFilesEx verbosity searchPath extensions moduleNames = - traverse (findModuleFileEx verbosity searchPath extensions) moduleNames - -{-# DEPRECATED findModuleFile "Use findModuleFileEx instead. This symbol will be removed in Cabal 3.2 (est. December 2019)" #-} -findModuleFile :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFile = findModuleFileEx normal - --- | Find the file corresponding to a Haskell module name. --- --- This is similar to 'findFileWithExtension'' but specialised to a module --- name. The function fails if the file corresponding to the module is missing. --- -findModuleFileEx :: Verbosity - -> [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFileEx verbosity searchPath extensions mod_name = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath mod_name) - where - notFound = die' verbosity $ - "Error: Could not find module: " ++ prettyShow mod_name - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files - ,reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ------------------------- --- Environment variables - --- | Is this directory in the system search path? -isInSearchPath :: FilePath -> IO Bool -isInSearchPath path = fmap (elem path) getSearchPath - -addLibraryPath :: OS - -> [FilePath] - -> [(String,String)] - -> [(String,String)] -addLibraryPath os paths = addEnv - where - pathsString = intercalate [searchPathSeparator] paths - ldPath = case os of - OSX -> "DYLD_LIBRARY_PATH" - _ -> "LD_LIBRARY_PATH" - - addEnv [] = [(ldPath,pathsString)] - addEnv ((key,value):xs) - | key == ldPath = - if null value - then (key,pathsString):xs - else (key,value ++ (searchPathSeparator:pathsString)):xs - | otherwise = (key,value):addEnv xs - --------------------- --- Modification time - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Like 'moreRecentFile', but also checks that the first file exists. -existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool -existsAndIsMoreRecentThan a b = do - exists <- doesFileExist a - if not exists - then return False - else a `moreRecentFile` b - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity - -> Bool -- ^ Create its parents too? - -> FilePath - -> IO () -createDirectoryIfMissingVerbose verbosity create_parents path0 - | create_parents = withFrozenCallStack $ createDirs (parents path0) - | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) - where - parents = reverse . scanl1 () . splitDirectories . normalise - - createDirs [] = return () - createDirs (dir:[]) = createDir dir throwIO - createDirs (dir:dirs) = - createDir dir $ \_ -> do - createDirs dirs - createDir dir throwIO - - createDir :: FilePath -> (IOException -> IO ()) -> IO () - createDir dir notExistHandler = do - r <- tryIO $ createDirectoryVerbose verbosity dir - case (r :: Either IOException ()) of - Right () -> return () - Left e - | isDoesNotExistError e -> notExistHandler e - -- createDirectory (and indeed POSIX mkdir) does not distinguish - -- between a dir already existing and a file already existing. So we - -- check for it here. Unfortunately there is a slight race condition - -- here, but we think it is benign. It could report an exception in - -- the case that the dir did exist but another process deletes the - -- directory and creates a file in its place before we can check - -- that the directory did indeed exist. - | isAlreadyExistsError e -> (do - isDir <- doesDirectoryExist dir - unless isDir $ throwIO e - ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) - | otherwise -> throwIO e - -createDirectoryVerbose :: Verbosity -> FilePath -> IO () -createDirectoryVerbose verbosity dir = withFrozenCallStack $ do - info verbosity $ "creating " ++ dir - createDirectory dir - setDirOrdinary dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = withFrozenCallStack $ do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = withFrozenCallStack $ do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Install a file that may or not be executable, preserving permissions. -installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do - perms <- getPermissions src - if (executable perms) --only checks user x bit - then installExecutableFile verbosity src dest - else installOrdinaryFile verbosity src dest - --- | Given a relative path to a file, copy it to the given directory, preserving --- the relative path and creating the parent directories if needed. -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = withFrozenCallStack $ do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - installOrdinaryFile verbosity file targetFile - --- | Common implementation of 'copyFiles', 'installOrdinaryFiles', --- 'installExecutableFiles' and 'installMaybeExecutableFiles'. -copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ()) - -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in doCopy verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) - --- | This is like 'copyFiles' but uses 'installExecutableFile'. --- -installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) - --- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. --- -installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] - -> IO () -installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - --- | Recursively copy the contents of one directory to another path. -copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f) - | f <- srcFiles ] - -------------------- --- File permissions - --- | Like 'doesFileExist', but also checks that the file is executable. -doesExecutableExist :: FilePath -> IO Bool -doesExecutableExist f = do - exists <- doesFileExist f - if exists - then do perms <- getPermissions f - return (executable perms) - else return False - ---------------------------- --- Temporary files and dirs - --- | Advanced options for 'withTempFile' and 'withTempDirectory'. -data TempFileOptions = TempFileOptions { - optKeepTempFiles :: Bool -- ^ Keep temporary files? - } - -defaultTempFileOptions :: TempFileOptions -defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False } - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - withTempFileEx defaultTempFileOptions tmpDir template action - --- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' --- argument. -withTempFileEx :: TempFileOptions - -> FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFileEx opts tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> do hClose handle - unless (optKeepTempFiles opts) $ - handleDoesNotExist () . removeFile $ name) - (withLexicalCallStack (\x -> uncurry action x)) - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory verbosity targetDir template f = withFrozenCallStack $ - withTempDirectoryEx verbosity defaultTempFileOptions targetDir template - (withLexicalCallStack (\x -> f x)) - --- | A version of 'withTempDirectory' that additionally takes a --- 'TempFileOptions' argument. -withTempDirectoryEx :: Verbosity -> TempFileOptions - -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $ - Exception.bracket - (createTempDirectory targetDir template) - (unless (optKeepTempFiles opts) - . handleDoesNotExist () . removeDirectoryRecursive) - (withLexicalCallStack (\x -> f x)) - ------------------------------------ --- Safely reading and writing files - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- --- NB: Before Cabal-3.0 the file content was assumed to be --- ASCII-representable. Since Cabal-3.0 the file is assumed to be --- UTF-8 encoded. -rewriteFileEx :: Verbosity -> FilePath -> String -> IO () -rewriteFileEx verbosity path = - rewriteFileLBS verbosity path . toUTF8LBS - --- | Same as `rewriteFileEx` but for 'ByteString's. -rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () -rewriteFileLBS verbosity path newContent = - flip catchIO mightNotExist $ do - existingContent <- annotateIO verbosity $ BS.readFile path - _ <- evaluate (BS.length existingContent) - unless (existingContent == newContent) $ - annotateIO verbosity $ - writeFileAtomic path newContent - where - mightNotExist e | isDoesNotExistError e - = annotateIO verbosity $ writeFileAtomic path newContent - | otherwise - = ioError e - - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - -shortRelativePath :: FilePath -> FilePath -> FilePath -shortRelativePath from to = - case dropCommonPrefix (splitDirectories from) (splitDirectories to) of - (stuff, path) -> joinPath (map (const "..") stuff ++ path) - where - dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a]) - dropCommonPrefix (x:xs) (y:ys) - | x == y = dropCommonPrefix xs ys - dropCommonPrefix xs ys = (xs,ys) - --- | Drop the extension if it's one of 'exeExtensions', or return the path --- unchanged. -dropExeExtension :: FilePath -> FilePath -dropExeExtension filepath = - -- System.FilePath's extension handling functions are horribly - -- inconsistent, consider: - -- - -- isExtensionOf "" "foo" == False but - -- isExtensionOf "" "foo." == True. - -- - -- On the other hand stripExtension doesn't remove the empty extension: - -- - -- stripExtension "" "foo." == Just "foo." - -- - -- Since by "" in exeExtensions we mean 'no extension' anyways we can - -- just always ignore it here. - let exts = [ ext | ext <- exeExtensions, ext /= "" ] in - fromMaybe filepath $ do - ext <- find (`FilePath.isExtensionOf` filepath) exts - ext `FilePath.stripExtension` filepath - --- | List of possible executable file extensions on the current build --- platform. -exeExtensions :: [String] -exeExtensions = case buildOS of - -- Possible improvement: on Windows, read the list of extensions from the - -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; - -- .cmd". - Windows -> ["", "exe"] - Ghcjs -> ["", "exe"] - _ -> [""] - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- | Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO (Either String FilePath) -- ^.cabal -findPackageDesc = findPackageDescCwd "." - --- | @since 3.4.0.0 -findPackageDescCwd - :: FilePath -- ^ project root - -> FilePath -- ^ relative directory - -> IO (Either String FilePath) -- ^ .cabal relative to the project root -findPackageDescCwd cwd dir - = do files <- getDirectoryContents (cwd dir) - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM (doesFileExist . snd) - [ (dir file, cwd dir file) - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case map fst cabalFiles of - [] -> return (Left noDesc) - [cabalFile] -> return (Right cabalFile) - multiple -> return (Left $ multiDesc multiple) - - where - noDesc :: String - noDesc = "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> String - multiDesc l = "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ intercalate ", " l - --- |Like 'findPackageDesc', but calls 'die' in case of error. -tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath -tryFindPackageDesc verbosity dir = - either (die' verbosity) return =<< findPackageDesc dir - --- | Like 'findPackageDescCwd', but calls 'die' in case of error. --- --- @since 3.4.0.0 -tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath -tryFindPackageDescCwd verbosity cwd dir = - either (die' verbosity) return =<< findPackageDescCwd cwd dir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: Verbosity - -> FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc verbosity dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +#ifdef GIT_REV +{-# LANGUAGE TemplateHaskell #-} +#endif + +----------------------------------------------------------------------------- + +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- License : BSD3 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. +module Distribution.Simple.Utils + ( cabalVersion + , cabalGitInfo + + -- * logging and errors + , dieNoVerbosity + , die' + , dieWithException + , dieWithLocation' + , dieNoWrap + , topHandler + , topHandlerWith + , warn + , warnError + , notice + , noticeNoWrap + , noticeDoc + , setupMessage + , info + , infoNoWrap + , debug + , debugNoWrap + , chattyTry + , annotateIO + , exceptionWithMetadata + , withOutputMarker + + -- * exceptions + , handleDoesNotExist + , ignoreSigPipe + + -- * running programs + , rawSystemExit + , rawSystemExitCode + , rawSystemProc + , rawSystemProcAction + , rawSystemExitWithEnv + , rawSystemExitWithEnvCwd + , rawSystemStdout + , rawSystemStdInOut + , rawSystemIOWithEnv + , rawSystemIOWithEnvAndAction + , fromCreatePipe + , maybeExit + , xargs + , findProgramVersion + + -- ** 'IOData' re-export + + -- + -- These types are re-exported from + -- "Distribution.Utils.IOData" for convenience as they're + -- exposed in the API of 'rawSystemStdInOut' + , IOData (..) + , KnownIODataMode (..) + , IODataMode (..) + , VerboseException (..) + + -- * copying files + , createDirectoryIfMissingVerbose + , copyFileVerbose + , copyFiles + , copyFileTo + , copyFileToCwd + + -- * installing files + , installOrdinaryFile + , installExecutableFile + , installMaybeExecutableFile + , installOrdinaryFiles + , installExecutableFiles + , installMaybeExecutableFiles + , installDirectoryContents + , copyDirectoryRecursive + + -- * File permissions + , doesExecutableExist + , setFileOrdinary + , setFileExecutable + + -- * file names + , shortRelativePath + , dropExeExtension + , exeExtensions + + -- * finding files + , findFileEx + , findFileCwd + , findFirstFile + , Suffix (..) + , findFileWithExtension + , findFileCwdWithExtension + , findFileWithExtension' + , findFileCwdWithExtension' + , findAllFilesWithExtension + , findAllFilesCwdWithExtension + , findModuleFileEx + , findModuleFileCwd + , findModuleFilesEx + , findModuleFilesCwd + , getDirectoryContentsRecursive + + -- * environment variables + , isInSearchPath + , addLibraryPath + + -- * modification time + , moreRecentFile + , existsAndIsMoreRecentThan + + -- * temp files and dirs + , TempFileOptions (..) + , defaultTempFileOptions + , withTempFile + , withTempFileCwd + , withTempFileEx + , withTempDirectory + , withTempDirectoryCwd + , withTempDirectoryEx + , withTempDirectoryCwdEx + , createTempDirectory + + -- * .cabal and .buildinfo files + , defaultPackageDescCwd + , findPackageDesc + , tryFindPackageDesc + , findHookedPackageDesc + + -- * reading and writing files safely + , withFileContents + , writeFileAtomic + , rewriteFileEx + , rewriteFileLBS + + -- * Unicode + , fromUTF8BS + , fromUTF8LBS + , toUTF8BS + , toUTF8LBS + , readUTF8File + , withUTF8FileContents + , writeUTF8File + , normaliseLineEndings + + -- * BOM + , ignoreBOM + + -- * generic utils + , dropWhileEndLE + , takeWhileEndLE + , equating + , comparing + , isInfixOf + , intercalate + , lowercase + , listUnion + , listUnionRight + , ordNub + , sortNub + , ordNubBy + , ordNubRight + , safeHead + , safeTail + , safeLast + , safeInit + , unintersperse + , wrapText + , wrapLine + , stripCommonPrefix + + -- * FilePath stuff + , isAbsoluteOnAnyPlatform + , isRelativeOnAnyPlatform + , exceptionWithCallStackPrefix + ) where + +import Distribution.Compat.Async (waitCatch, withAsyncNF) +import Distribution.Compat.CopyFile +import Distribution.Compat.FilePath as FilePath +import Distribution.Compat.Internal.TempFile +import Distribution.Compat.Lens (Lens', over) +import Distribution.Compat.Prelude +import Distribution.Compat.Stack +import Distribution.ModuleName as ModuleName +import Distribution.Simple.Errors +import Distribution.Simple.PreProcess.Types +import Distribution.System +import Distribution.Types.PackageId +import Distribution.Utils.Generic +import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..)) +import qualified Distribution.Utils.IOData as IOData +import Distribution.Utils.Path +import Distribution.Verbosity +import Distribution.Version +import Prelude () + +#ifdef CURRENT_PACKAGE_KEY +#define BOOTSTRAPPED_CABAL 1 +#endif + +#ifdef BOOTSTRAPPED_CABAL +import qualified Paths_Cabal (version) +#endif + +import Distribution.Parsec +import Distribution.Pretty + +import qualified Data.ByteString.Lazy as BS +import Data.Typeable + ( cast + ) + +import qualified Control.Exception as Exception +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) +import Distribution.Compat.Process (proc) +import Foreign.C.Error (Errno (..), ePIPE) +import qualified GHC.IO.Exception as GHC +import GHC.Stack (HasCallStack) +import Numeric (showFFloat) +import System.Directory + ( Permissions (executable) + , createDirectory + , doesDirectoryExist + , doesFileExist + , getDirectoryContents + , getModificationTime + , getPermissions + , getTemporaryDirectory + , removeDirectoryRecursive + , removeFile + ) +import System.Environment + ( getProgName + ) +import System.FilePath (takeFileName) +import System.FilePath as FilePath + ( getSearchPath + , joinPath + , normalise + , searchPathSeparator + , splitDirectories + , splitExtension + , takeDirectory + ) +import System.IO + ( BufferMode (..) + , Handle + , hClose + , hFlush + , hGetContents + , hPutStr + , hPutStrLn + , hSetBinaryMode + , hSetBuffering + , stderr + , stdout + ) +import System.IO.Error +import System.IO.Unsafe + ( unsafeInterleaveIO + ) +import qualified System.Process as Process +import qualified Text.PrettyPrint as Disp + +#ifdef GIT_REV +import Data.Either (isLeft) +import GitHash + ( giHash + , giBranch + , giCommitDate + , tGitInfoCwdTry + ) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(BOOTSTRAPPED_CABAL) +cabalVersion = mkVersion' Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = mkVersion [CABAL_VERSION] +#else +cabalVersion = mkVersion [3,0] --used when bootstrapping +#endif + +-- | +-- `Cabal` Git information. Only filled in if built in a Git tree in +-- development mode and Template Haskell is available. +cabalGitInfo :: String +#ifdef GIT_REV +cabalGitInfo = if giHash' == "" + then "" + else concat [ "(commit " + , giHash' + , branchInfo + , ", " + , either (const "") giCommitDate gi' + , ")" + ] + where + gi' = $$tGitInfoCwdTry + giHash' = take 7 . either (const "") giHash $ gi' + branchInfo | isLeft gi' = "" + | either id giBranch gi' == "master" = "" + | otherwise = " on " <> either id giBranch gi' +#else +cabalGitInfo = "" +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +-- Cabal's logging infrastructure has a few constraints: +-- +-- * We must make all logging formatting and emissions decisions based +-- on the 'Verbosity' parameter, which is the only parameter that is +-- plumbed to enough call-sites to actually be used for this matter. +-- (One of Cabal's "big mistakes" is to have never have defined a +-- monad of its own.) +-- +-- * When we 'die', we must raise an IOError. This a backwards +-- compatibility consideration, because that's what we've raised +-- previously, and if we change to any other exception type, +-- exception handlers which match on IOError will no longer work. +-- One case where it is known we rely on IOError being catchable +-- is 'readPkgConfigDb' in cabal-install; there may be other +-- user code that also assumes this. +-- +-- * The 'topHandler' does not know what 'Verbosity' is, because +-- it gets called before we've done command line parsing (where +-- the 'Verbosity' parameter would come from). +-- +-- This leads to two big architectural choices: +-- +-- * Although naively we might imagine 'Verbosity' to be a simple +-- enumeration type, actually it is a full-on abstract data type +-- that may contain arbitrarily complex information. At the +-- moment, it is fully representable as a string, but we might +-- eventually also use verbosity to let users register their +-- own logging handler. +-- +-- * When we call 'die', we perform all the formatting and addition +-- of extra information we need, and then ship this in the IOError +-- to the top-level handler. Here are alternate designs that +-- don't work: +-- +-- a) Ship the unformatted info to the handler. This doesn't +-- work because at the point the handler gets the message, +-- we've lost call stacks, and even if we did, we don't have access +-- to 'Verbosity' to decide whether or not to render it. +-- +-- b) Print the information at the 'die' site, then raise an +-- error. This means that if the exception is subsequently +-- caught by a handler, we will still have emitted the output, +-- which is not the correct behavior. +-- +-- For the top-level handler to "know" that an error message +-- contains one of these fully formatted packets, we set a sentinel +-- in one of IOError's extra fields. This is handled by +-- 'ioeSetVerbatim' and 'ioeGetVerbatim'. +-- + +dieNoVerbosity :: String -> IO a +dieNoVerbosity msg = + ioError (userError msg) + where + _ = callStack -- TODO: Attach CallStack to exception + +-- | Tag an 'IOError' whose error string should be output to the screen +-- verbatim. +ioeSetVerbatim :: IOError -> IOError +ioeSetVerbatim e = ioeSetLocation e "dieVerbatim" + +-- | Check if an 'IOError' should be output verbatim to screen. +ioeGetVerbatim :: IOError -> Bool +ioeGetVerbatim e = ioeGetLocation e == "dieVerbatim" + +-- | Create a 'userError' whose error text will be output verbatim +verbatimUserError :: String -> IOError +verbatimUserError = ioeSetVerbatim . userError + +dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a +dieWithLocation' verbosity filename mb_lineno msg = + die' verbosity $ + filename + ++ ( case mb_lineno of + Just lineno -> ":" ++ show lineno + Nothing -> "" + ) + ++ ": " + ++ msg + +die' :: Verbosity -> String -> IO a +die' verbosity msg = withFrozenCallStack $ do + ioError . verbatimUserError + =<< annotateErrorString verbosity + =<< pure . wrapTextVerbosity verbosity + =<< pure . addErrorPrefix + =<< prefixWithProgName msg + +-- Type which will be a wrapper for cabal -exceptions and cabal-install exceptions +data VerboseException a = VerboseException CallStack POSIXTime Verbosity a + deriving (Show) + +-- Function which will replace the existing die' call sites +dieWithException :: (HasCallStack, Show a1, Typeable a1, Exception (VerboseException a1)) => Verbosity -> a1 -> IO a +dieWithException verbosity exception = do + ts <- getPOSIXTime + throwIO $ VerboseException callStack ts verbosity exception + +-- Instance for Cabal Exception which will display error code and error message with callStack info +instance Exception (VerboseException CabalException) where + displayException :: VerboseException CabalException -> [Char] + displayException (VerboseException stack timestamp verb cabalexception) = + withOutputMarker + verb + ( concat + [ "Error: [Cabal-" + , show (exceptionCode cabalexception) + , "]\n" + ] + ) + ++ exceptionWithMetadata stack timestamp verb (exceptionMessage cabalexception) + +dieNoWrap :: Verbosity -> String -> IO a +dieNoWrap verbosity msg = withFrozenCallStack $ do + -- TODO: should this have program name or not? + ioError . verbatimUserError + =<< annotateErrorString + verbosity + (addErrorPrefix msg) + +-- | Prefixing a message to indicate that it is a fatal error, +-- if the 'errorPrefix' is not already present. +addErrorPrefix :: String -> String +addErrorPrefix msg + | errorPrefix `isPrefixOf` msg = msg + -- Backpack prefixes its errors already with "Error:", see + -- 'Distribution.Utils.LogProgress.dieProgress'. + -- Taking it away there destroys the layout, so we rather + -- check here whether the prefix is already present. + | otherwise = unwords [errorPrefix, msg] + +-- | A prefix indicating that a message is a fatal error. +errorPrefix :: String +errorPrefix = "Error:" + +-- | Prefix an error string with program name from 'getProgName' +prefixWithProgName :: String -> IO String +prefixWithProgName msg = do + pname <- getProgName + return $ pname ++ ": " ++ msg + +-- | Annotate an error string with timestamp and 'withMetadata'. +annotateErrorString :: Verbosity -> String -> IO String +annotateErrorString verbosity msg = do + ts <- getPOSIXTime + return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg + +-- | Given a block of IO code that may raise an exception, annotate +-- it with the metadata from the current scope. Use this as close +-- to external code that raises IO exceptions as possible, since +-- this function unconditionally wraps the error message with a trace +-- (so it is NOT idempotent.) +annotateIO :: Verbosity -> IO a -> IO a +annotateIO verbosity act = do + ts <- getPOSIXTime + flip modifyIOError act $ + ioeModifyErrorString $ + withMetadata ts NeverMark VerboseTrace verbosity + +-- | A semantic editor for the error message inside an 'IOError'. +ioeModifyErrorString :: (String -> String) -> IOError -> IOError +ioeModifyErrorString = over ioeErrorString + +-- | A lens for the error message inside an 'IOError'. +ioeErrorString :: Lens' IOError String +ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe) + +{-# NOINLINE topHandlerWith #-} +topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a +topHandlerWith cont prog = do + -- By default, stderr to a terminal device is NoBuffering. But this + -- is *really slow* + hSetBuffering stderr LineBuffering + Exception.catches + prog + [ Exception.Handler rethrowAsyncExceptions + , Exception.Handler rethrowExitStatus + , Exception.Handler handle + ] + where + -- Let async exceptions rise to the top for the default top-handler + rethrowAsyncExceptions :: Exception.AsyncException -> IO a + rethrowAsyncExceptions a = throwIO a + + -- ExitCode gets thrown asynchronously too, and we don't want to print it + rethrowExitStatus :: ExitCode -> IO a + rethrowExitStatus = throwIO + + -- Print all other exceptions + handle :: Exception.SomeException -> IO a + handle se = do + hFlush stdout + pname <- getProgName + hPutStr stderr (message pname se) + cont se + + message :: String -> Exception.SomeException -> String + message pname (Exception.SomeException se) = + case cast se :: Maybe Exception.IOException of + Just ioe + | ioeGetVerbatim ioe -> + -- Use the message verbatim + ioeGetErrorString ioe ++ "\n" + | isUserError ioe -> + let file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " + location = case ioeGetLocation ioe of + l@(n : _) | isDigit n -> ':' : l + _ -> "" + detail = ioeGetErrorString ioe + in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail + _ -> + displaySomeException se ++ "\n" + +-- | BC wrapper around 'Exception.displayException'. +displaySomeException :: Exception.Exception e => e -> String +displaySomeException se = Exception.displayException se + +topHandler :: IO a -> IO a +topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog + +-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'. +verbosityHandle :: Verbosity -> Handle +verbosityHandle verbosity + | isVerboseStderr verbosity = stderr + | otherwise = stdout + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +warn :: Verbosity -> String -> IO () +warn verbosity msg = warnMessage "Warning" verbosity msg + +-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the +-- the message. Useful when you want to highlight the condition is an error +-- but do not want to quit the program yet. +warnError :: Verbosity -> String -> IO () +warnError verbosity message = warnMessage "Error" verbosity message + +-- | Warning message, with a custom label. +warnMessage :: String -> Verbosity -> String -> IO () +warnMessage l verbosity msg = withFrozenCallStack $ do + when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do + ts <- getPOSIXTime + hFlush stdout + hPutStr stderr + . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ l ++ ": " ++ msg + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +notice :: Verbosity -> String -> IO () +notice verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +-- | Display a message at 'normal' verbosity level, but without +-- wrapping. +noticeNoWrap :: Verbosity -> String -> IO () +noticeNoWrap verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + +-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity +-- level. Use this if you need fancy formatting. +noticeDoc :: Verbosity -> Disp.Doc -> IO () +noticeDoc verbosity msg = withFrozenCallStack $ do + when (verbosity >= normal) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NormalMark FlagTrace verbosity $ + Disp.renderStyle defaultStyle $ + msg + +-- | Display a "setup status message". Prefer using setupMessage' +-- if possible. +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = withFrozenCallStack $ do + noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +info :: Verbosity -> String -> IO () +info verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + +infoNoWrap :: Verbosity -> String -> IO () +infoNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= verbose) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +debug :: Verbosity -> String -> IO () +debug verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + wrapTextVerbosity verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | A variant of 'debug' that doesn't perform the automatic line +-- wrapping. Produces better output in some cases. +debugNoWrap :: Verbosity -> String -> IO () +debugNoWrap verbosity msg = withFrozenCallStack $ + when (verbosity >= deafening) $ do + let h = verbosityHandle verbosity + ts <- getPOSIXTime + hPutStr h $ + withMetadata ts NeverMark FlagTrace verbosity $ + msg + -- ensure that we don't lose output if we segfault/infinite loop + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry + :: String + -- ^ a description of the action we were attempting + -> IO () + -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + +-- | Run an IO computation, returning @e@ if it raises a "file +-- does not exist" error. +handleDoesNotExist :: a -> IO a -> IO a +handleDoesNotExist e = + Exception.handleJust + (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing) + (\_ -> return e) + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text unless the @+nowrap@ verbosity flag is active +wrapTextVerbosity :: Verbosity -> String -> String +wrapTextVerbosity verb + | isVerboseNoWrap verb = withTrailingNewline + | otherwise = withTrailingNewline . wrapText + +-- | Prepends a timestamp if @+timestamp@ verbosity flag is set +-- +-- This is used by 'withMetadata' +withTimestamp :: Verbosity -> POSIXTime -> String -> String +withTimestamp v ts msg + | isVerboseTimestamp v = msg' + | otherwise = msg -- no-op + where + msg' = case lines msg of + [] -> tsstr "\n" + l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest) + + -- format timestamp to be prepended to first line with msec precision + tsstr = showFFloat (Just 3) (realToFrac ts :: Double) + + -- continuation prefix for subsequent lines of msg + contpfx = replicate (length (tsstr " ")) ' ' + +-- | Wrap output with a marker if @+markoutput@ verbosity flag is set. +-- +-- NB: Why is markoutput done with start/end markers, and not prefixes? +-- Markers are more convenient to add (if we want to add prefixes, +-- we have to 'lines' and then 'map'; here's it's just some +-- concatenates). Note that even in the prefix case, we can't +-- guarantee that the markers are unambiguous, because some of +-- Cabal's output comes straight from external programs, where +-- we don't have the ability to interpose on the output. +-- +-- This is used by 'withMetadata' +withOutputMarker :: Verbosity -> String -> String +withOutputMarker v xs | not (isVerboseMarkOutput v) = xs +withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly +withOutputMarker _ xs = + "-----BEGIN CABAL OUTPUT-----\n" + ++ withTrailingNewline xs + ++ "-----END CABAL OUTPUT-----\n" + +-- | Append a trailing newline to a string if it does not +-- already have a trailing newline. +withTrailingNewline :: String -> String +withTrailingNewline "" = "" +withTrailingNewline (x : xs) = x : go x xs + where + go _ (c : cs) = c : go c cs + go '\n' "" = "" + go _ "" = "\n" + +-- | Prepend a call-site and/or call-stack based on Verbosity +withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String) +withCallStackPrefix tracer verbosity s = + withFrozenCallStack $ + ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( case traceWhen verbosity tracer of + Just pre -> pre ++ prettyCallStack callStack ++ "\n" + Nothing -> "" + ) + ++ s + +-- | When should we emit the call stack? We always emit +-- for internal errors, emit the trace for errors when we +-- are in verbose mode, and otherwise only emit it if +-- explicitly asked for using the @+callstack@ verbosity +-- flag. (At the moment, 'AlwaysTrace' is not used. +data TraceWhen + = AlwaysTrace + | VerboseTrace + | FlagTrace + deriving (Eq) + +-- | Determine if we should emit a call stack. +-- If we trace, it also emits any prefix we should append. +traceWhen :: Verbosity -> TraceWhen -> Maybe String +traceWhen _ AlwaysTrace = Just "" +traceWhen v VerboseTrace | v >= verbose = Just "" +traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n" +traceWhen _ _ = Nothing + +-- | When should we output the marker? Things like 'die' +-- always get marked, but a 'NormalMark' will only be +-- output if we're not a quiet verbosity. +data MarkWhen = AlwaysMark | NormalMark | NeverMark + +-- | Add all necessary metadata to a logging message +withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String) +withMetadata ts marker tracer verbosity x = + withFrozenCallStack + $ + -- NB: order matters. Output marker first because we + -- don't want to capture call stacks. + withTrailingNewline + . withCallStackPrefix tracer verbosity + . ( case marker of + AlwaysMark -> withOutputMarker verbosity + NormalMark + | not (isVerboseQuiet verbosity) -> + withOutputMarker verbosity + | otherwise -> + id + NeverMark -> id + ) + -- Clear out any existing markers + . clearMarkers + . withTimestamp verbosity ts + $ x + +-- | Add all necessary metadata to a logging message +exceptionWithMetadata :: CallStack -> POSIXTime -> Verbosity -> String -> String +exceptionWithMetadata stack ts verbosity x = + withTrailingNewline + . exceptionWithCallStackPrefix stack verbosity + . withOutputMarker verbosity + . clearMarkers + . withTimestamp verbosity ts + $ x + +clearMarkers :: String -> String +clearMarkers s = unlines . filter isMarker $ lines s + where + isMarker "-----BEGIN CABAL OUTPUT-----" = False + isMarker "-----END CABAL OUTPUT-----" = False + isMarker _ = True + +-- | Append a call-site and/or call-stack based on Verbosity +exceptionWithCallStackPrefix :: CallStack -> Verbosity -> String -> String +exceptionWithCallStackPrefix stack verbosity s = + s + ++ withFrozenCallStack + ( ( if isVerboseCallSite verbosity + then + parentSrcLocPrefix + ++ + -- Hack: need a newline before starting output marker :( + if isVerboseMarkOutput verbosity + then "\n" + else "" + else "" + ) + ++ ( if verbosity >= verbose + then prettyCallStack stack ++ "\n" + else "" + ) + ) + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +-- +-- These all use 'Distribution.Compat.Process.proc' to ensure we +-- consistently use process jobs on Windows and Ctrl-C delegation +-- on Unix. +-- +-- Additionally, they take care of logging command execution. +-- + +-- | Helper to use with one of the 'rawSystem' variants, and exit +-- unless the command completes successfully. +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + exitcode <- cmd + unless (exitcode == ExitSuccess) $ exitWith exitcode + +-- | Log a command execution (that's typically about to happen) +-- at info level, and log working directory and environment overrides +-- at debug level if specified. +logCommand :: Verbosity -> Process.CreateProcess -> IO () +logCommand verbosity cp = do + infoNoWrap verbosity $ + "Running: " <> case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path args -> Process.showCommandForUser path args + case Process.env cp of + Just env -> debugNoWrap verbosity $ "with environment: " ++ show env + Nothing -> return () + case Process.cwd cp of + Just cwd -> debugNoWrap verbosity $ "with working directory: " ++ show cwd + Nothing -> return () + hFlush stdout + +-- | Execute the given command with the given arguments, exiting +-- with the same exit code if the command fails. +rawSystemExit :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> FilePath -> [String] -> IO () +rawSystemExit verbosity mbWorkDir path args = + withFrozenCallStack $ + maybeExit $ + rawSystemExitCode verbosity mbWorkDir path args Nothing + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +rawSystemExitCode + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> FilePath + -> [String] + -> Maybe [(String, String)] + -> IO ExitCode +rawSystemExitCode verbosity mbWorkDir path args menv = + withFrozenCallStack $ + rawSystemProc verbosity $ + (proc path args) + { Process.cwd = fmap getSymbolicPath mbWorkDir + , Process.env = menv + } + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode +rawSystemProc verbosity cp = withFrozenCallStack $ do + (exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return () + return exitcode + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Create the process argument with 'Distribution.Compat.Process.proc' +-- to ensure consistent options with other 'rawSystem' functions in this +-- module. +rawSystemProcAction + :: Verbosity + -> Process.CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a) + -> IO (ExitCode, a) +rawSystemProcAction verbosity cp action = withFrozenCallStack $ do + logCommand verbosity cp + (exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do + a <- action mStdin mStdout mStderr + exitcode <- Process.waitForProcess p + return (exitcode, a) + unless (exitcode == ExitSuccess) $ do + let cmd = case Process.cmdspec cp of + Process.ShellCommand sh -> sh + Process.RawCommand path _args -> path + debug verbosity $ cmd ++ " returned " ++ show exitcode + return (exitcode, a) + +-- | fromJust for dealing with 'Maybe Handle' values as obtained via +-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees +-- a 'Just' value for the corresponding handle. +fromCreatePipe :: Maybe Handle -> Handle +fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id + +-- | Execute the given command with the given arguments and +-- environment, exiting with the same exit code if the command fails. +rawSystemExitWithEnv + :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity = + rawSystemExitWithEnvCwd verbosity Nothing + +-- | Like 'rawSystemExitWithEnv', but setting a working directory. +rawSystemExitWithEnvCwd + :: Verbosity + -> Maybe (SymbolicPath CWD to) + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnvCwd verbosity mbWorkDir path args env = + withFrozenCallStack $ + maybeExit $ + rawSystemProc verbosity $ + (proc path args) + { Process.env = Just env + , Process.cwd = getSymbolicPath <$> mbWorkDir + } + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnv + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + (exitcode, _) <- + rawSystemIOWithEnvAndAction + verbosity + path + args + mcwd + menv + action + inp + out + err + return exitcode + where + action = return () + +-- | Execute the given command with the given arguments, returning +-- the command's exit code. 'action' is executed while the command +-- is running, and would typically be used to communicate with the +-- process through pipes. +-- +-- Optional arguments allow setting working directory, environment +-- and input and output handles. +rawSystemIOWithEnvAndAction + :: Verbosity + -> FilePath + -> [String] + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> IO a + -- ^ action to perform after process is created, but before 'waitForProcess'. + -> Maybe Handle + -- ^ stdin + -> Maybe Handle + -- ^ stdout + -> Maybe Handle + -- ^ stderr + -> IO (ExitCode, a) +rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = mbToStd inp + , Process.std_out = mbToStd out + , Process.std_err = mbToStd err + } + rawSystemProcAction verbosity cp (\_ _ _ -> action) + where + mbToStd :: Maybe Handle -> Process.StdStream + mbToStd = maybe Process.Inherit Process.UseHandle + +-- | Execute the given command with the given arguments, returning +-- the command's output. Exits if the command exits with error. +-- +-- Provides control over the binary/text mode of the output. +rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode +rawSystemStdout verbosity path args = withFrozenCallStack $ do + (output, errors, exitCode) <- + rawSystemStdInOut + verbosity + path + args + Nothing + Nothing + Nothing + (IOData.iodataMode :: IODataMode mode) + when (exitCode /= ExitSuccess) $ + dieWithException verbosity $ + RawSystemStdout errors + return output + +-- | Execute the given command with the given arguments, returning +-- the command's output, errors and exit code. +-- +-- Optional arguments allow setting working directory, environment +-- and command input. +-- +-- Provides control over the binary/text mode of the input and output. +rawSystemStdInOut + :: KnownIODataMode mode + => Verbosity + -> FilePath + -- ^ Program location + -> [String] + -- ^ Arguments + -> Maybe FilePath + -- ^ New working dir or inherit + -> Maybe [(String, String)] + -- ^ New environment or inherit + -> Maybe IOData + -- ^ input text and binary mode + -> IODataMode mode + -- ^ iodata mode, acts as proxy + -> IO (mode, String, ExitCode) + -- ^ output, errors, exit +rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do + let cp = + (proc path args) + { Process.cwd = mcwd + , Process.env = menv + , Process.std_in = Process.CreatePipe + , Process.std_out = Process.CreatePipe + , Process.std_err = Process.CreatePipe + } + + (exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do + let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err) + flip Exception.finally (hClose inh >> hClose outh >> hClose errh) $ do + -- output mode depends on what the caller wants + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do + -- push all the input, if any + ignoreSigPipe $ case input of + Nothing -> hClose inh + Just inputData -> IOData.hPutContents inh inputData + + -- wait for both to finish + mberr1 <- waitCatch outA + mberr2 <- waitCatch errA + return (mberr1, mberr2) + + -- get the stderr, so it can be added to error message + err <- reportOutputIOError mberr2 + + unless (exitcode == ExitSuccess) $ + debug verbosity $ + path + ++ " returned " + ++ show exitcode + ++ if null err + then "" + else + " with error message:\n" + ++ err + ++ case input of + Nothing -> "" + Just d | IOData.null d -> "" + Just (IODataText inp) -> "\nstdin input:\n" ++ inp + Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp + + -- Check if we hit an exception while consuming the output + -- (e.g. a text decoding error) + out <- reportOutputIOError mberr1 + + return (out, err, exitcode) + where + reportOutputIOError :: Either Exception.SomeException a -> IO a + reportOutputIOError (Right x) = return x + reportOutputIOError (Left exc) = case fromException exc of + Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path)) + Nothing -> throwIO exc + +-- | Ignore SIGPIPE in a subcomputation. +ignoreSigPipe :: IO () -> IO () +ignoreSigPipe = Exception.handle $ \case + GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe} + | Errno ioe == ePIPE -> return () + e -> throwIO e + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +findProgramVersion + :: String + -- ^ version args + -> (String -> String) + -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath + -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do + str <- + rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catch` (\(_ :: VerboseException CabalException) -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParsec (selectVersion str) + case version of + Nothing -> + warn verbosity $ + "cannot determine version of " + ++ path + ++ " :\n" + ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v + return version + +-- | Like the Unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +xargs + :: Int + -> ([String] -> IO ()) + -> [String] + -> [String] + -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + where + chunks len = unfoldr $ \s -> + if null s + then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc, []) + chunk acc len (s : ss) + | len' < len = chunk (s : acc) (len - len' - 1) ss + | otherwise = (reverse acc, s : ss) + where + len' = length s + +-- ------------------------------------------------------------ + +-- * File Utilities + +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +-- @since 3.4.0.0 +findFileCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ search directories + -> RelativePath searchDir File + -- ^ File Name + -> IO (SymbolicPathX allowAbsolute Pkg File) +findFileCwd verbosity mbWorkDir searchPath fileName = + findFirstFile + (interpretSymbolicPath mbWorkDir) + [ path fileName + | path <- ordNub searchPath + ] + >>= maybe (dieWithException verbosity $ FindFile $ getSymbolicPath fileName) return + +-- | Find a file by looking in a search path. The file path must match exactly. +findFileEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ search directories + -> RelativePath searchDir File + -- ^ File Name + -> IO (SymbolicPathX allowAbsolute Pkg File) +findFileEx v = findFileCwd v Nothing + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +findFileWithExtension + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File)) +findFileWithExtension = + findFileCwdWithExtension Nothing + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. +-- +-- @since 3.4.0.0 +findFileCwdWithExtension + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -> [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg File)) +findFileCwdWithExtension cwd extensions searchPath baseName = + fmap (uncurry ()) + <$> findFileCwdWithExtension' cwd extensions searchPath baseName + +-- | @since 3.4.0.0 +findAllFilesCwdWithExtension + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> [Suffix] + -- ^ extensions + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ relative search locations + -> RelativePath searchDir File + -- ^ basename + -> IO [SymbolicPathX allowAbsolute Pkg File] +findAllFilesCwdWithExtension mbWorkDir extensions searchPath basename = + findAllFiles + (interpretSymbolicPath mbWorkDir) + [ path basename <.> ext + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + +findAllFilesWithExtension + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO [SymbolicPathX allowAbsolute Pkg File] +findAllFilesWithExtension = + findAllFilesCwdWithExtension Nothing + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +findFileWithExtension' + :: [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)) +findFileWithExtension' = + findFileCwdWithExtension' Nothing + +-- | Like 'findFileCwdWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +findFileCwdWithExtension' + :: forall searchDir allowAbsolute + . Maybe (SymbolicPath CWD (Dir Pkg)) + -> [Suffix] + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -> RelativePath searchDir File + -> IO (Maybe (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)) +findFileCwdWithExtension' cwd extensions searchPath baseName = + findFirstFile + (uncurry mkPath) + [ (path, baseName <.> ext) + | path <- ordNub searchPath + , Suffix ext <- ordNub extensions + ] + where + mkPath :: SymbolicPathX allowAbsolute Pkg (Dir searchDir) -> RelativePath searchDir File -> FilePath + mkPath base file = + interpretSymbolicPath cwd (base file) + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where + findFirst [] = return Nothing + findFirst (x : xs) = do + exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +findAllFiles :: (a -> FilePath) -> [a] -> IO [a] +findAllFiles file = filterM (doesFileExist . file) + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +findModuleFilesEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)] +findModuleFilesEx verbosity searchPath extensions moduleNames = + traverse (findModuleFileEx verbosity searchPath extensions) moduleNames + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFileCwd' but for a list of module names. +findModuleFilesCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> [ModuleName] + -- ^ modules + -> IO [(SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File)] +findModuleFilesCwd verbosity cwd searchPath extensions moduleNames = + traverse (findModuleFileCwd verbosity cwd searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +findModuleFileEx + :: forall searchDir allowAbsolute + . Verbosity + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File) +findModuleFileEx verbosity = + findModuleFileCwd verbosity Nothing + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileCwdWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +findModuleFileCwd + :: forall searchDir allowAbsolute + . Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> [SymbolicPathX allowAbsolute Pkg (Dir searchDir)] + -- ^ build prefix (location of objects) + -> [Suffix] + -- ^ search suffixes + -> ModuleName + -- ^ module + -> IO (SymbolicPathX allowAbsolute Pkg (Dir searchDir), RelativePath searchDir File) +findModuleFileCwd verbosity cwd searchPath extensions mod_name = do + mbRes <- + findFileCwdWithExtension' + cwd + extensions + searchPath + (makeRelativePathEx $ ModuleName.toFilePath mod_name) + case mbRes of + Nothing -> + dieWithException verbosity $ + FindModuleFileEx mod_name extensions (map getSymbolicPath searchPath) + Just res -> return res + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + where + collect files dirs' [] = + return + ( reverse files + , reverse dirs' + ) + collect files dirs' (entry : entries) + | ignore entry = + collect files dirs' entries + collect files dirs' (entry : entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry : dirs') entries + else collect (dirEntry : files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +------------------------ +-- Environment variables + +-- | Is this directory in the system search path? +isInSearchPath :: FilePath -> IO Bool +isInSearchPath path = fmap (elem path) getSearchPath + +addLibraryPath + :: OS + -> [FilePath] + -> [(String, String)] + -> [(String, String)] +addLibraryPath os paths = addEnv + where + pathsString = intercalate [searchPathSeparator] paths + ldPath = case os of + OSX -> "DYLD_LIBRARY_PATH" + _ -> "LD_LIBRARY_PATH" + + addEnv [] = [(ldPath, pathsString)] + addEnv ((key, value) : xs) + | key == ldPath = + if null value + then (key, pathsString) : xs + else (key, value ++ (searchPathSeparator : pathsString)) : xs + | otherwise = (key, value) : addEnv xs + +-------------------- +-- Modification time + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do + tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Like 'moreRecentFile', but also checks that the first file exists. +existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool +existsAndIsMoreRecentThan a b = do + exists <- doesFileExist a + if not exists + then return False + else a `moreRecentFile` b + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +createDirectoryIfMissingVerbose + :: Verbosity + -> Bool + -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = withFrozenCallStack $ createDirs (parents path0) + | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir : []) = createDir dir throwIO + createDirs (dir : dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exception in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> + ( do + isDir <- doesDirectoryExist dir + unless isDir $ throwIO e + ) + `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = withFrozenCallStack $ do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = withFrozenCallStack $ do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = withFrozenCallStack $ do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Install a file that may or not be executable, preserving permissions. +installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do + perms <- getPermissions src + if (executable perms) -- only checks user x bit + then installExecutableFile verbosity src dest + else installOrdinaryFile verbosity src dest + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileTo + :: Verbosity + -> FilePath + -> FilePath + -> IO () +copyFileTo verbosity dir file = + withFrozenCallStack $ + copyFileToCwd + verbosity + Nothing + (makeSymbolicPath dir) + (makeRelativePathEx file) + +-- | Given a relative path to a file, copy it to the given directory, preserving +-- the relative path and creating the parent directories if needed. +copyFileToCwd + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -> SymbolicPath Pkg (Dir target) + -> RelativePath Pkg File + -> IO () +copyFileToCwd verbosity mbWorkDir dir file = withFrozenCallStack $ do + let targetFile = i $ dir unsafeCoerceSymbolicPath file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity (i file) targetFile + where + i :: SymbolicPathX allowAbs Pkg to -> FilePath + i = interpretSymbolicPath mbWorkDir + +-- | Common implementation of 'copyFiles', 'installOrdinaryFiles', +-- 'installExecutableFiles' and 'installMaybeExecutableFiles'. +copyFilesWith + :: (Verbosity -> FilePath -> FilePath -> IO ()) + -> Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do + -- Create parent directories for everything + let dirs = map (targetDir ) . ordNub . map (takeDirectory . snd) $ srcFiles + traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ + [ let src = srcBase srcFile + dest = targetDir srcFile + in doCopy verbosity src dest + | (srcBase, srcFile) <- srcFiles + ] + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs) + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installExecutableFile'. +installExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs) + +-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'. +installMaybeExecutableFiles + :: Verbosity + -> FilePath + -> [(FilePath, FilePath)] + -> IO () +installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs) + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles] + +-- | Recursively copy the contents of one directory to another path. +copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFilesWith + (const copyFile) + verbosity + destDir + [ (srcDir, f) + | f <- srcFiles + ] + +------------------- +-- File permissions + +-- | Like 'doesFileExist', but also checks that the file is executable. +doesExecutableExist :: FilePath -> IO Bool +doesExecutableExist f = do + exists <- doesFileExist f + if exists + then do + perms <- getPermissions f + return (executable perms) + else return False + +--------------------------- +-- Temporary files and dirs + +-- | Advanced options for 'withTempFile' and 'withTempDirectory'. +data TempFileOptions = TempFileOptions + { optKeepTempFiles :: Bool + -- ^ Keep temporary files? + } + +defaultTempFileOptions :: TempFileOptions +defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False} + +-- | Use a temporary filename that doesn't already exist +withTempFile + :: String + -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) + -> IO a +withTempFile template f = withFrozenCallStack $ + withTempFileCwd template $ + \fp h -> f (getSymbolicPath fp) h + +-- | Use a temporary filename that doesn't already exist. +withTempFileCwd + :: String + -- ^ File name template. See 'openTempFile'. + -> (SymbolicPath Pkg File -> Handle -> IO a) + -> IO a +withTempFileCwd = withFrozenCallStack $ withTempFileEx defaultTempFileOptions + +-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions' +-- argument. +withTempFileEx + :: forall a + . TempFileOptions + -> String + -- ^ File name template. See 'openTempFile'. + -> (SymbolicPath Pkg File -> Handle -> IO a) + -> IO a +withTempFileEx opts template action = do + tmp <- getTemporaryDirectory + withFrozenCallStack $ + Exception.bracket + (openTempFile tmp template) + ( \(name, handle) -> do + hClose handle + unless (optKeepTempFiles opts) $ + handleDoesNotExist () $ + removeFile $ + name + ) + (withLexicalCallStack (\(fn, h) -> action (mkRelToPkg tmp fn) h)) + where + mkRelToPkg :: FilePath -> FilePath -> SymbolicPath Pkg File + mkRelToPkg tmp fp = + makeSymbolicPath tmp makeRelativePathEx (takeFileName fp) + +-- 'openTempFile' returns a path of the form @i tmpDir fn@, but we +-- want 'withTempFileEx' to return @tmpDir fn@. So we split off +-- the filename and add back the (un-interpreted) directory. +-- This assumes 'openTempFile' returns a filepath of the form +-- @inputDir fn@, where @fn@ does not contain any path separators. + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory + :: Verbosity + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectory verb targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwd + verb + Nothing + (makeSymbolicPath targetDir) + template + (f . getSymbolicPath) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectoryCwd + :: Verbosity + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir tmpDir1) + -> String + -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) + -> IO a +withTempDirectoryCwd verbosity mbWorkDir targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwdEx + verbosity + defaultTempFileOptions + mbWorkDir + targetDir + template + (withLexicalCallStack (\x -> f x)) + +-- | A version of 'withTempDirectory' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryEx + :: Verbosity + -> TempFileOptions + -> FilePath + -> String + -> (FilePath -> IO a) + -> IO a +withTempDirectoryEx verbosity opts targetDir template f = + withFrozenCallStack $ + withTempDirectoryCwdEx verbosity opts Nothing (makeSymbolicPath targetDir) template $ + \fp -> f (getSymbolicPath fp) + +-- | A version of 'withTempDirectoryCwd' that additionally takes a +-- 'TempFileOptions' argument. +withTempDirectoryCwdEx + :: forall a tmpDir1 tmpDir2 + . Verbosity + -> TempFileOptions + -> Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ Working directory + -> SymbolicPath Pkg (Dir tmpDir1) + -> String + -> (SymbolicPath Pkg (Dir tmpDir2) -> IO a) + -> IO a +withTempDirectoryCwdEx _verbosity opts mbWorkDir targetDir template f = + withFrozenCallStack $ + Exception.bracket + (createTempDirectory (i targetDir) template) + ( \tmpDirRelPath -> + unless (optKeepTempFiles opts) $ + handleDoesNotExist () $ + removeDirectoryRecursive (i targetDir tmpDirRelPath) + ) + (withLexicalCallStack (\tmpDirRelPath -> f $ targetDir makeRelativePathEx tmpDirRelPath)) + where + i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path + +----------------------------------- +-- Safely reading and writing files + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +-- NB: Before Cabal-3.0 the file content was assumed to be +-- ASCII-representable. Since Cabal-3.0 the file is assumed to be +-- UTF-8 encoded. +rewriteFileEx :: Verbosity -> FilePath -> String -> IO () +rewriteFileEx verbosity path = + rewriteFileLBS verbosity path . toUTF8LBS + +-- | Same as `rewriteFileEx` but for 'ByteString's. +rewriteFileLBS :: Verbosity -> FilePath -> BS.ByteString -> IO () +rewriteFileLBS verbosity path newContent = + flip catchIO mightNotExist $ do + existingContent <- annotateIO verbosity $ BS.readFile path + _ <- evaluate (BS.length existingContent) + unless (existingContent == newContent) $ + annotateIO verbosity $ + writeFileAtomic path newContent + where + mightNotExist e + | isDoesNotExistError e = + annotateIO verbosity $ writeFileAtomic path newContent + | otherwise = + ioError e + +shortRelativePath :: FilePath -> FilePath -> FilePath +shortRelativePath from to = + case dropCommonPrefix (splitDirectories from) (splitDirectories to) of + (stuff, path) -> joinPath (map (const "..") stuff ++ path) + where + dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a]) + dropCommonPrefix (x : xs) (y : ys) + | x == y = dropCommonPrefix xs ys + dropCommonPrefix xs ys = (xs, ys) + +-- | Drop the extension if it's one of 'exeExtensions', or return the path +-- unchanged. +dropExeExtension :: FilePath -> FilePath +dropExeExtension filepath = + -- System.FilePath's extension handling functions are horribly + -- inconsistent, consider: + -- + -- isExtensionOf "" "foo" == False but + -- isExtensionOf "" "foo." == True. + -- + -- On the other hand stripExtension doesn't remove the empty extension: + -- + -- stripExtension "" "foo." == Just "foo." + -- + -- Since by "" in exeExtensions we mean 'no extension' anyways we can + -- just always ignore it here. + let exts = [ext | ext <- exeExtensions, ext /= ""] + in fromMaybe filepath $ do + ext <- find (`FilePath.isExtensionOf` filepath) exts + ext `FilePath.stripExtension` filepath + +-- | List of possible executable file extensions on the current build +-- platform. +exeExtensions :: [String] +exeExtensions = case (buildArch, buildOS) of + -- Possible improvement: on Windows, read the list of extensions from the + -- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat; + -- .cmd". + -- + -- See also #10179. + -- + -- Also we cannot actually run @.bat@ files as we do now, because of + -- https://github.com/haskell/process/issues/140. If we detect one of those, + -- we should record that the program is a script and run a @Process.shell@ instead + -- of a @Process.proc@. + (_, Windows) -> ["", "exe"] + (_, Ghcjs) -> ["", "exe"] + (Wasm32, _) -> ["", "wasm"] + _ -> [""] + +-- ------------------------------------------------------------ + +-- * Finding the description file + +-- ------------------------------------------------------------ + +-- | Package description file (/pkgname/@.cabal@) in the current +-- working directory. +defaultPackageDescCwd :: Verbosity -> IO (RelativePath Pkg File) +defaultPackageDescCwd verbosity = tryFindPackageDesc verbosity Nothing + +-- | Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc + :: Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ package directory + -> IO (Either CabalException (RelativePath Pkg File)) +findPackageDesc mbPkgDir = + do + let pkgDir = maybe "." getSymbolicPath mbPkgDir + files <- getDirectoryContents pkgDir + -- to make sure we do not mistake a ~/.cabal/ dir for a .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 diff --git a/src/Distribution/Simple/Utils/Json.hs b/src/Distribution/Simple/Utils/Json.hs deleted file mode 100644 --- a/src/Distribution/Simple/Utils/Json.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Utility json lib for Cabal --- TODO: Remove it again. -module Distribution.Simple.Utils.Json - ( Json(..) - , renderJson - ) where - -data Json = JsonArray [Json] - | JsonBool !Bool - | JsonNull - | JsonNumber !Int - | JsonObject [(String, Json)] - | JsonString !String - -renderJson :: Json -> ShowS -renderJson (JsonArray objs) = - surround "[" "]" $ intercalate "," $ map renderJson objs -renderJson (JsonBool True) = showString "true" -renderJson (JsonBool False) = showString "false" -renderJson JsonNull = showString "null" -renderJson (JsonNumber n) = shows n -renderJson (JsonObject attrs) = - surround "{" "}" $ intercalate "," $ map render attrs - where - render (k,v) = (surround "\"" "\"" $ showString' k) . showString ":" . renderJson v -renderJson (JsonString s) = surround "\"" "\"" $ showString' s - -surround :: String -> String -> ShowS -> ShowS -surround begin end middle = showString begin . middle . showString end - -showString' :: String -> ShowS -showString' xs = showStringWorker xs - where - showStringWorker :: String -> ShowS - showStringWorker ('\"':as) = showString "\\\"" . showStringWorker as - showStringWorker ('\\':as) = showString "\\\\" . showStringWorker as - showStringWorker ('\'':as) = showString "\\\'" . showStringWorker as - showStringWorker (x:as) = showString [x] . showStringWorker as - showStringWorker [] = showString "" - -intercalate :: String -> [ShowS] -> ShowS -intercalate sep = go - where - go [] = id - go [x] = x - go (x:xs) = x . showString' sep . go xs diff --git a/src/Distribution/System.hs b/src/Distribution/System.hs deleted file mode 100644 --- a/src/Distribution/System.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.System --- Copyright : Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Cabal often needs to do slightly different things on specific platforms. You --- probably know about the 'System.Info.os' however using that is very --- inconvenient because it is a string and different Haskell implementations --- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it --- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - platformFromTriple, - - -- * Internal - knownOSs, - knownArches, - - -- * Classification - ClassificationStrictness (..), - classifyOS, - classifyArch, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Applicative (liftA2) - -import qualified System.Info (os, arch) -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- The reason we have multiple ways to do the classification is because there --- are two situations where we need to do it. --- --- For parsing OS and arch names in .cabal files we really want everyone to be --- referring to the same or arch by the same name. Variety is not a virtue --- in this case. We don't mind about case though. --- --- For the System.Info.os\/arch different Haskell implementations use different --- names for the same or\/arch. Also they tend to distinguish versions of an --- OS\/arch which we just don't care about. --- --- The 'Compat' classification allows us to recognise aliases that are already --- in common use but it allows us to distinguish them from the canonical name --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - --- | These are the known OS names: Linux, Windows, OSX --- ,FreeBSD, OpenBSD, NetBSD, DragonFly --- ,Solaris, AIX, HPUX, IRIX --- ,HaLVM ,Hurd ,IOS, Android,Ghcjs --- --- The following aliases can also be used:, --- * Windows aliases: mingw32, win32, cygwin32 --- * OSX alias: darwin --- * Hurd alias: gnu --- * FreeBSD alias: kfreebsdgnu --- * Solaris alias: solaris2 --- -data OS = Linux | Windows | OSX -- tier 1 desktop OSs - | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs - | DragonFly - | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs - | HaLVM -- bare metal / VMs / hypervisors - | Hurd -- GNU's microkernel - | IOS | Android -- mobile OSs - | Ghcjs - | OtherOS String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary OS -instance Structured OS -instance NFData OS where rnf = genericRnf - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD, DragonFly - ,Solaris, AIX, HPUX, IRIX - ,HaLVM - ,Hurd - ,IOS, Android - ,Ghcjs] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases _ Hurd = ["gnu"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Compat FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases Compat Solaris = ["solaris2"] -osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"] -osAliases Compat Android = ["linux-android"] -osAliases _ _ = [] - -instance Pretty OS where - pretty (OtherOS name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec OS where - parsec = classifyOS Compat <$> parsecIdent - - - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - fromMaybe (OtherOS s) $ lookup (lowercase s) osMap - where - osMap = [ (name, os) - | os <- knownOSs - , name <- prettyShow os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - --- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc, --- Arm, AArch64, Mips, SH, IA64, S39, Alpha, Hppa, Rs6000, M68k, --- Vax, and JavaScript. --- --- The following aliases can also be used: --- * PPC alias: powerpc --- * PPC64 alias : powerpc64, powerpc64le --- * Sparc aliases: sparc64, sun4 --- * Mips aliases: mipsel, mipseb --- * Arm aliases: armeb, armel --- * AArch64 aliases: arm64 --- -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | AArch64 | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | JavaScript - | OtherArch String - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Arch -instance Structured Arch -instance NFData Arch where rnf = genericRnf - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, AArch64, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax - ,JavaScript] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64", "powerpc64le"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ AArch64 = ["arm64"] -archAliases _ _ = [] - -instance Pretty Arch where - pretty (OtherArch name) = Disp.text name - pretty other = Disp.text (lowercase (show other)) - -instance Parsec Arch where - parsec = classifyArch Strict <$> parsecIdent - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - fromMaybe (OtherArch s) $ lookup (lowercase s) archMap - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- prettyShow arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - --- ------------------------------------------------------------ --- * Platform --- ------------------------------------------------------------ - -data Platform = Platform Arch OS - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data) - -instance Binary Platform -instance Structured Platform -instance NFData Platform where rnf = genericRnf - -instance Pretty Platform where - pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os - -instance Parsec Platform where - -- TODO: there are ambigious platforms like: `arch-word-os` - -- which could be parsed as - -- * Platform "arch-word" "os" - -- * Platform "arch" "word-os" - -- We could support that preferring variants 'OtherOS' or 'OtherArch' - -- - -- For now we split into arch and os parts on the first dash. - parsec = do - arch <- parsecDashlessArch - _ <- P.char '-' - os <- parsec - return (Platform arch os) - where - parsecDashlessArch = classifyArch Strict <$> dashlessIdent - - dashlessIdent = liftA2 (:) firstChar rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_') - --- | The platform Cabal was compiled on. In most cases, --- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're --- targeting). -buildPlatform :: Platform -buildPlatform = Platform buildArch buildOS - --- Utils: - -parsecIdent :: CabalParsing m => m String -parsecIdent = (:) <$> firstChar <*> rest - where - firstChar = P.satisfy isAlpha - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - -platformFromTriple :: String -> Maybe Platform -platformFromTriple triple = - either (const Nothing) Just $ explicitEitherParsec parseTriple triple - where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_') - parseTriple = do - arch <- fmap (classifyArch Permissive) parseWord - _ <- P.char '-' - _ <- parseWord -- Skip vendor - _ <- P.char '-' - os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like - -- 'nto-qnx' - return $ Platform arch os diff --git a/src/Distribution/TestSuite.hs b/src/Distribution/TestSuite.hs --- a/src/Distribution/TestSuite.hs +++ b/src/Distribution/TestSuite.hs @@ -2,6 +2,7 @@ {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- + -- | -- Module : Distribution.TestSuite -- Copyright : Thomas Tuegel 2010 @@ -12,91 +13,97 @@ -- -- This module defines the detailed test suite interface which makes it -- possible to expose individual tests to Cabal or other test agents. - module Distribution.TestSuite - ( TestInstance(..) - , OptionDescr(..) - , OptionType(..) - , Test(..) - , Options - , Progress(..) - , Result(..) - , testGroup - ) where + ( TestInstance (..) + , OptionDescr (..) + , OptionType (..) + , Test (..) + , Options + , Progress (..) + , Result (..) + , testGroup + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data TestInstance = TestInstance - { run :: IO Progress -- ^ Perform the test. - , name :: String -- ^ A name for the test, unique within a - -- test suite. - , tags :: [String] -- ^ Users can select groups of tests by - -- their tags. - , options :: [OptionDescr] -- ^ Descriptions of the options recognized - -- by this test. - , setOption :: String -> String -> Either String TestInstance - -- ^ Try to set the named option to the given value. Returns an error - -- message if the option is not supported or the value could not be - -- correctly parsed; otherwise, a 'TestInstance' with the option set to - -- the given value is returned. - } + { run :: IO Progress + -- ^ Perform the test. + , name :: String + -- ^ A name for the test, unique within a + -- test suite. + , tags :: [String] + -- ^ Users can select groups of tests by + -- their tags. + , options :: [OptionDescr] + -- ^ Descriptions of the options recognized + -- by this test. + , setOption :: String -> String -> Either String TestInstance + -- ^ Try to set the named option to the given value. Returns an error + -- message if the option is not supported or the value could not be + -- correctly parsed; otherwise, a 'TestInstance' with the option set to + -- the given value is returned. + } data OptionDescr = OptionDescr - { optionName :: String - , optionDescription :: String -- ^ A human-readable description of the - -- option to guide the user setting it. - , optionType :: OptionType - , optionDefault :: Maybe String - } + { optionName :: String + , optionDescription :: String + -- ^ A human-readable description of the + -- option to guide the user setting it. + , optionType :: OptionType + , optionDefault :: Maybe String + } deriving (Eq, Read, Show) data OptionType - = OptionFile - { optionFileMustExist :: Bool - , optionFileIsDir :: Bool - , optionFileExtensions :: [String] - } - | OptionString - { optionStringMultiline :: Bool - } - | OptionNumber - { optionNumberIsInt :: Bool - , optionNumberBounds :: (Maybe String, Maybe String) - } - | OptionBool - | OptionEnum [String] - | OptionSet [String] - | OptionRngSeed + = OptionFile + { optionFileMustExist :: Bool + , optionFileIsDir :: Bool + , optionFileExtensions :: [String] + } + | OptionString + { optionStringMultiline :: Bool + } + | OptionNumber + { optionNumberIsInt :: Bool + , optionNumberBounds :: (Maybe String, Maybe String) + } + | OptionBool + | OptionEnum [String] + | OptionSet [String] + | OptionRngSeed deriving (Eq, Read, Show) data Test - = Test TestInstance - | Group - { groupName :: String - , concurrently :: Bool - -- ^ If true, then children of this group may be run in parallel. - -- Note that this setting is not inherited by children. In - -- particular, consider a group F with "concurrently = False" that - -- has some children, including a group T with "concurrently = - -- True". The children of group T may be run concurrently with each - -- other, as long as none are run at the same time as any of the - -- direct children of group F. - , groupTests :: [Test] - } - | ExtraOptions [OptionDescr] Test + = Test TestInstance + | Group + { groupName :: String + , concurrently :: Bool + -- ^ If true, then children of this group may be run in parallel. + -- Note that this setting is not inherited by children. In + -- particular, consider a group F with "concurrently = False" that + -- has some children, including a group T with "concurrently = + -- True". The children of group T may be run concurrently with each + -- other, as long as none are run at the same time as any of the + -- direct children of group F. + , groupTests :: [Test] + } + | ExtraOptions [OptionDescr] Test type Options = [(String, String)] -data Progress = Finished Result - | Progress String (IO Progress) +data Progress + = Finished Result + | Progress String (IO Progress) -data Result = Pass - | Fail String - | Error String +data Result + = Pass + | Fail String + | Error String deriving (Eq, Read, Show) -- | Create a named group of tests, which are assumed to be safe to run in -- parallel. testGroup :: String -> [Test] -> Test -testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts } +testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts} diff --git a/src/Distribution/Text.hs b/src/Distribution/Text.hs deleted file mode 100644 --- a/src/Distribution/Text.hs +++ /dev/null @@ -1,12 +0,0 @@ --- Since @3.0@ this is a compat module. -module Distribution.Text (display, simpleParse) where -{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -} - -import Distribution.Pretty -import Distribution.Parsec - -display :: Pretty a => a -> String -display = prettyShow - -simpleParse :: Parsec a => String -> Maybe a -simpleParse = simpleParsec diff --git a/src/Distribution/Types/AbiDependency.hs b/src/Distribution/Types/AbiDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/AbiDependency.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.AbiDependency where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Package as Package -import qualified Text.PrettyPrint as Disp - --- | An ABI dependency is a dependency on a library which also --- records the ABI hash ('abiHash') of the library it depends --- on. --- --- The primary utility of this is to enable an extra sanity when --- GHC loads libraries: it can check if the dependency has a matching --- ABI and if not, refuse to load this library. This information --- is critical if we are shadowing libraries; differences in the --- ABI hash let us know what packages get shadowed by the new version --- of a package. -data AbiDependency = AbiDependency { - depUnitId :: Package.UnitId, - depAbiHash :: Package.AbiHash - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty AbiDependency where - pretty (AbiDependency uid abi) = - pretty uid <<>> Disp.char '=' <<>> pretty abi - -instance Parsec AbiDependency where - parsec = do - uid <- parsec - _ <- P.char '=' - abi <- parsec - return (AbiDependency uid abi) - -instance Binary AbiDependency -instance Structured AbiDependency -instance NFData AbiDependency where rnf = genericRnf diff --git a/src/Distribution/Types/AbiHash.hs b/src/Distribution/Types/AbiHash.hs deleted file mode 100644 --- a/src/Distribution/Types/AbiHash.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.AbiHash - ( AbiHash, unAbiHash, mkAbiHash - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec - -import Text.PrettyPrint (text) - --- | ABI Hashes --- --- Use 'mkAbiHash' and 'unAbiHash' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype AbiHash = AbiHash ShortText - deriving (Eq, Show, Read, Generic, Typeable) - --- | Construct a 'AbiHash' from a 'String' --- --- 'mkAbiHash' is the inverse to 'unAbiHash' --- --- Note: No validations are performed to ensure that the resulting --- 'AbiHash' is valid --- --- @since 2.0.0.2 -unAbiHash :: AbiHash -> String -unAbiHash (AbiHash h) = fromShortText h - --- | Convert 'AbiHash' to 'String' --- --- @since 2.0.0.2 -mkAbiHash :: String -> AbiHash -mkAbiHash = AbiHash . toShortText - --- | 'mkAbiHash' --- --- @since 2.0.0.2 -instance IsString AbiHash where - fromString = mkAbiHash - -instance Binary AbiHash -instance Structured AbiHash -instance NFData AbiHash where rnf = genericRnf - -instance Pretty AbiHash where - pretty = text . unAbiHash - -instance Parsec AbiHash where - parsec = fmap mkAbiHash (P.munch isAlphaNum) diff --git a/src/Distribution/Types/AnnotatedId.hs b/src/Distribution/Types/AnnotatedId.hs --- a/src/Distribution/Types/AnnotatedId.hs +++ b/src/Distribution/Types/AnnotatedId.hs @@ -1,9 +1,11 @@ -module Distribution.Types.AnnotatedId ( - AnnotatedId(..) -) where +{-# LANGUAGE DeriveFunctor #-} -import Prelude () +module Distribution.Types.AnnotatedId + ( AnnotatedId (..) + ) where + import Distribution.Compat.Prelude +import Prelude () import Distribution.Package import Distribution.Types.ComponentName @@ -14,21 +16,18 @@ -- -- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y -- and ann_cname x == ann_cname y -data AnnotatedId id = AnnotatedId { - ann_pid :: PackageId, - ann_cname :: ComponentName, - ann_id :: id - } - deriving (Show) +data AnnotatedId id = AnnotatedId + { ann_pid :: PackageId + , ann_cname :: ComponentName + , ann_id :: id + } + deriving (Show, Functor) instance Eq id => Eq (AnnotatedId id) where - x == y = ann_id x == ann_id y + x == y = ann_id x == ann_id y instance Ord id => Ord (AnnotatedId id) where - compare x y = compare (ann_id x) (ann_id y) + compare x y = compare (ann_id x) (ann_id y) instance Package (AnnotatedId id) where - packageId = ann_pid - -instance Functor AnnotatedId where - fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x) + packageId = ann_pid diff --git a/src/Distribution/Types/Benchmark.hs b/src/Distribution/Types/Benchmark.hs deleted file mode 100644 --- a/src/Distribution/Types/Benchmark.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Benchmark ( - Benchmark(..), - emptyBenchmark, - benchmarkType, - benchmarkModules, - benchmarkModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.BenchmarkType -import Distribution.Types.BenchmarkInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"benchmark\" stanza in a cabal file. --- -data Benchmark = Benchmark { - benchmarkName :: UnqualComponentName, - benchmarkInterface :: BenchmarkInterface, - benchmarkBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Benchmark -instance Structured Benchmark -instance NFData Benchmark where rnf = genericRnf - -instance L.HasBuildInfo Benchmark where - buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) - -instance Monoid Benchmark where - mempty = Benchmark { - benchmarkName = mempty, - benchmarkInterface = mempty, - benchmarkBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup Benchmark where - a <> b = Benchmark { - benchmarkName = combine' benchmarkName, - benchmarkInterface = combine benchmarkInterface, - benchmarkBuildInfo = combine benchmarkBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyBenchmark :: Benchmark -emptyBenchmark = mempty - -benchmarkType :: Benchmark -> BenchmarkType -benchmarkType benchmark = case benchmarkInterface benchmark of - BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver - BenchmarkUnsupported benchmarktype -> benchmarktype - --- | Get all the module names from a benchmark. -benchmarkModules :: Benchmark -> [ModuleName] -benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark) - --- | Get all the auto generated module names from a benchmark. --- This are a subset of 'benchmarkModules'. -benchmarkModulesAutogen :: Benchmark -> [ModuleName] -benchmarkModulesAutogen benchmark = autogenModules (benchmarkBuildInfo benchmark) diff --git a/src/Distribution/Types/Benchmark/Lens.hs b/src/Distribution/Types/Benchmark/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Benchmark/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.Benchmark.Lens ( - Benchmark, - module Distribution.Types.Benchmark.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.BenchmarkInterface (BenchmarkInterface) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Benchmark as T - -benchmarkName :: Lens' Benchmark UnqualComponentName -benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) -{-# INLINE benchmarkName #-} - -benchmarkInterface :: Lens' Benchmark BenchmarkInterface -benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) -{-# INLINE benchmarkInterface #-} - -benchmarkBuildInfo :: Lens' Benchmark BuildInfo -benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s)) -{-# INLINE benchmarkBuildInfo #-} diff --git a/src/Distribution/Types/BenchmarkInterface.hs b/src/Distribution/Types/BenchmarkInterface.hs deleted file mode 100644 --- a/src/Distribution/Types/BenchmarkInterface.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.BenchmarkInterface ( - BenchmarkInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BenchmarkType -import Distribution.Version - --- | The benchmark interfaces that are currently defined. Each --- benchmark must specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or --- totally new interfaces. --- -data BenchmarkInterface = - - -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark - -- takes the form of an executable. It returns a zero exit code - -- for success, non-zero for failure. The stdout and stderr - -- channels may be logged. It takes no command line parameters - -- and nothing on stdin. - -- - BenchmarkExeV10 Version FilePath - - -- | A benchmark that does not conform to one of the above - -- interfaces for the given reason (e.g. unknown benchmark type). - -- - | BenchmarkUnsupported BenchmarkType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary BenchmarkInterface -instance Structured BenchmarkInterface -instance NFData BenchmarkInterface where rnf = genericRnf - -instance Monoid BenchmarkInterface where - mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup BenchmarkInterface where - a <> (BenchmarkUnsupported _) = a - _ <> b = b diff --git a/src/Distribution/Types/BenchmarkType.hs b/src/Distribution/Types/BenchmarkType.hs deleted file mode 100644 --- a/src/Distribution/Types/BenchmarkType.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BenchmarkType ( - BenchmarkType(..), - knownBenchmarkTypes, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version -import Text.PrettyPrint (char, text) - --- | The \"benchmark-type\" field in the benchmark stanza. --- -data BenchmarkType = BenchmarkTypeExe Version - -- ^ \"type: exitcode-stdio-x.y\" - | BenchmarkTypeUnknown String Version - -- ^ Some unknown benchmark type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BenchmarkType -instance Structured BenchmarkType -instance NFData BenchmarkType where rnf = genericRnf - -knownBenchmarkTypes :: [BenchmarkType] -knownBenchmarkTypes = [ BenchmarkTypeExe (mkVersion [1,0]) ] - -instance Pretty BenchmarkType where - pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec BenchmarkType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> BenchmarkTypeExe ver - _ -> BenchmarkTypeUnknown name ver diff --git a/src/Distribution/Types/BuildInfo.hs b/src/Distribution/Types/BuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildInfo.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.BuildInfo ( - BuildInfo(..), - - emptyBuildInfo, - allLanguages, - allExtensions, - usedExtensions, - usesTemplateHaskellOrQQ, - - hcOptions, - hcProfOptions, - hcSharedOptions, - hcStaticOptions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Mixin -import Distribution.Types.Dependency -import Distribution.Types.ExeDependency -import Distribution.Types.LegacyExeDependency -import Distribution.Types.PkgconfigDependency -import Distribution.Utils.Path - -import Distribution.ModuleName -import Distribution.Compiler -import Language.Haskell.Extension - --- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo { - -- | component is buildable here - buildable :: Bool, - -- | Tools needed to build this bit. - -- - -- This is a legacy field that 'buildToolDepends' largely supersedes. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildTools :: [LegacyExeDependency], - -- | Haskell tools needed to build this bit - -- - -- This field is better than 'buildTools' because it allows one to - -- precisely specify an executable in a package. - -- - -- Unless use are very sure what you are doing, use the functions in - -- "Distribution.Simple.BuildToolDepends" rather than accessing this - -- field directly. - buildToolDepends :: [ExeDependency], - cppOptions :: [String], -- ^ options for pre-processing Haskell code - asmOptions :: [String], -- ^ options for assmebler - cmmOptions :: [String], -- ^ options for C-- compiler - ccOptions :: [String], -- ^ options for C compiler - cxxOptions :: [String], -- ^ options for C++ compiler - ldOptions :: [String], -- ^ options for linker - hsc2hsOptions :: [String], -- ^ options for hsc2hs - pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used - frameworks :: [String], -- ^support frameworks for Mac OS X - extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks. - asmSources :: [FilePath], -- ^ Assembly files. - cmmSources :: [FilePath], -- ^ C-- files. - cSources :: [FilePath], - cxxSources :: [FilePath], - jsSources :: [FilePath], - hsSourceDirs :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy - otherModules :: [ModuleName], -- ^ non-exposed or non-main modules - virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) - autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs - - defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified - otherLanguages :: [Language], -- ^ other languages used within the package - defaultExtensions :: [Extension], -- ^ language extensions used by all modules - otherExtensions :: [Extension], -- ^ other language extensions used within the package - oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' - - extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package - extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi. - extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package. - -- Example: the Cffi library shipping with the rts, alognside the HSrts-1.0.a,.o,... - -- Example 2: a library that is being built by a foreing tool (e.g. rust) - -- and copied and registered together with this library. The - -- logic on how this library is built will have to be encoded in a - -- custom Setup for now. Otherwise cabal would need to lear how to - -- call arbitrary library builders. - extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when - -- copying. E.g. [libHS_ | flavour <- extraLibFlavours]. This - -- should only be needed in very specific cases, e.g. the `rts` package, where - -- there are multiple copies of slightly differently built libs. - extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/ - -- libraries when copying. This is particularly useful with the `rts` package, - -- where we want different dynamic flavours of the RTS library to be installed. - extraLibDirs :: [String], - includeDirs :: [FilePath], -- ^directories to find .h files - includes :: [FilePath], -- ^ The .h files to be found in includeDirs - autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@) - installIncludes :: [FilePath], -- ^ .h files to install with the package - options :: PerCompilerFlavor [String], - profOptions :: PerCompilerFlavor [String], - sharedOptions :: PerCompilerFlavor [String], - staticOptions :: PerCompilerFlavor [String], - customFieldsBI :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target - mixins :: [Mixin] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildInfo -instance Structured BuildInfo -instance NFData BuildInfo where rnf = genericRnf - -instance Monoid BuildInfo where - mempty = BuildInfo { - buildable = True, - buildTools = [], - buildToolDepends = [], - cppOptions = [], - asmOptions = [], - cmmOptions = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - hsc2hsOptions = [], - pkgconfigDepends = [], - frameworks = [], - extraFrameworkDirs = [], - asmSources = [], - cmmSources = [], - cSources = [], - cxxSources = [], - jsSources = [], - hsSourceDirs = [], - otherModules = [], - virtualModules = [], - autogenModules = [], - defaultLanguage = Nothing, - otherLanguages = [], - defaultExtensions = [], - otherExtensions = [], - oldExtensions = [], - extraLibs = [], - extraGHCiLibs = [], - extraBundledLibs = [], - extraLibFlavours = [], - extraDynLibFlavours = [], - extraLibDirs = [], - includeDirs = [], - includes = [], - autogenIncludes = [], - installIncludes = [], - options = mempty, - profOptions = mempty, - sharedOptions = mempty, - staticOptions = mempty, - customFieldsBI = [], - targetBuildDepends = [], - mixins = [] - } - mappend = (<>) - -instance Semigroup BuildInfo where - a <> b = BuildInfo { - buildable = buildable a && buildable b, - buildTools = combine buildTools, - buildToolDepends = combine buildToolDepends, - cppOptions = combine cppOptions, - asmOptions = combine asmOptions, - cmmOptions = combine cmmOptions, - ccOptions = combine ccOptions, - cxxOptions = combine cxxOptions, - ldOptions = combine ldOptions, - hsc2hsOptions = combine hsc2hsOptions, - pkgconfigDepends = combine pkgconfigDepends, - frameworks = combineNub frameworks, - extraFrameworkDirs = combineNub extraFrameworkDirs, - asmSources = combineNub asmSources, - cmmSources = combineNub cmmSources, - cSources = combineNub cSources, - cxxSources = combineNub cxxSources, - jsSources = combineNub jsSources, - hsSourceDirs = combineNub hsSourceDirs, - otherModules = combineNub otherModules, - virtualModules = combineNub virtualModules, - autogenModules = combineNub autogenModules, - defaultLanguage = combineMby defaultLanguage, - otherLanguages = combineNub otherLanguages, - defaultExtensions = combineNub defaultExtensions, - otherExtensions = combineNub otherExtensions, - oldExtensions = combineNub oldExtensions, - extraLibs = combine extraLibs, - extraGHCiLibs = combine extraGHCiLibs, - extraBundledLibs = combine extraBundledLibs, - extraLibFlavours = combine extraLibFlavours, - extraDynLibFlavours = combine extraDynLibFlavours, - extraLibDirs = combineNub extraLibDirs, - includeDirs = combineNub includeDirs, - includes = combineNub includes, - autogenIncludes = combineNub autogenIncludes, - installIncludes = combineNub installIncludes, - options = combine options, - profOptions = combine profOptions, - sharedOptions = combine sharedOptions, - staticOptions = combine staticOptions, - customFieldsBI = combine customFieldsBI, - targetBuildDepends = combineNub targetBuildDepends, - mixins = combine mixins - } - where - combine field = field a `mappend` field b - combineNub field = nub (combine field) - combineMby field = field b `mplus` field a - -emptyBuildInfo :: BuildInfo -emptyBuildInfo = mempty - --- | The 'Language's used by this component --- -allLanguages :: BuildInfo -> [Language] -allLanguages bi = maybeToList (defaultLanguage bi) - ++ otherLanguages bi - --- | The 'Extension's that are used somewhere by this component --- -allExtensions :: BuildInfo -> [Extension] -allExtensions bi = usedExtensions bi - ++ otherExtensions bi - --- | The 'Extensions' that are used by all modules in this component --- -usedExtensions :: BuildInfo -> [Extension] -usedExtensions bi = oldExtensions bi - ++ defaultExtensions bi - --- | Whether any modules in this component use Template Haskell or --- Quasi Quotes -usesTemplateHaskellOrQQ :: BuildInfo -> Bool -usesTemplateHaskellOrQQ bi = any p (allExtensions bi) - where - p ex = ex `elem` - [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes] - --- |Select options for a particular Haskell compiler. -hcOptions :: CompilerFlavor -> BuildInfo -> [String] -hcOptions = lookupHcOptions options - -hcProfOptions :: CompilerFlavor -> BuildInfo -> [String] -hcProfOptions = lookupHcOptions profOptions - -hcSharedOptions :: CompilerFlavor -> BuildInfo -> [String] -hcSharedOptions = lookupHcOptions sharedOptions - -hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String] -hcStaticOptions = lookupHcOptions staticOptions - -lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String]) - -> CompilerFlavor -> BuildInfo -> [String] -lookupHcOptions f hc bi = case f bi of - PerCompilerFlavor ghc ghcjs - | hc == GHC -> ghc - | hc == GHCJS -> ghcjs - | otherwise -> mempty diff --git a/src/Distribution/Types/BuildInfo/Lens.hs b/src/Distribution/Types/BuildInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildInfo/Lens.hs +++ /dev/null @@ -1,342 +0,0 @@ -module Distribution.Types.BuildInfo.Lens ( - BuildInfo, - HasBuildInfo (..), - HasBuildInfos (..), - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Compiler (PerCompilerFlavor) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.ExeDependency (ExeDependency) -import Distribution.Types.LegacyExeDependency (LegacyExeDependency) -import Distribution.Types.Mixin (Mixin) -import Distribution.Types.PkgconfigDependency (PkgconfigDependency) -import Distribution.Utils.Path -import Language.Haskell.Extension (Extension, Language) - -import qualified Distribution.Types.BuildInfo as T - --- | Classy lenses for 'BuildInfo'. -class HasBuildInfo a where - buildInfo :: Lens' a BuildInfo - - buildable :: Lens' a Bool - buildable = buildInfo . buildable - {-# INLINE buildable #-} - - buildTools :: Lens' a [LegacyExeDependency] - buildTools = buildInfo . buildTools - {-# INLINE buildTools #-} - - buildToolDepends :: Lens' a [ExeDependency] - buildToolDepends = buildInfo . buildToolDepends - {-# INLINE buildToolDepends #-} - - cppOptions :: Lens' a [String] - cppOptions = buildInfo . cppOptions - {-# INLINE cppOptions #-} - - asmOptions :: Lens' a [String] - asmOptions = buildInfo . asmOptions - {-# INLINE asmOptions #-} - - cmmOptions :: Lens' a [String] - cmmOptions = buildInfo . cmmOptions - {-# INLINE cmmOptions #-} - - ccOptions :: Lens' a [String] - ccOptions = buildInfo . ccOptions - {-# INLINE ccOptions #-} - - cxxOptions :: Lens' a [String] - cxxOptions = buildInfo . cxxOptions - {-# INLINE cxxOptions #-} - - ldOptions :: Lens' a [String] - ldOptions = buildInfo . ldOptions - {-# INLINE ldOptions #-} - - hsc2hsOptions :: Lens' a [String] - hsc2hsOptions = buildInfo . hsc2hsOptions - {-# INLINE hsc2hsOptions #-} - - pkgconfigDepends :: Lens' a [PkgconfigDependency] - pkgconfigDepends = buildInfo . pkgconfigDepends - {-# INLINE pkgconfigDepends #-} - - frameworks :: Lens' a [String] - frameworks = buildInfo . frameworks - {-# INLINE frameworks #-} - - extraFrameworkDirs :: Lens' a [String] - extraFrameworkDirs = buildInfo . extraFrameworkDirs - {-# INLINE extraFrameworkDirs #-} - - asmSources :: Lens' a [FilePath] - asmSources = buildInfo . asmSources - {-# INLINE asmSources #-} - - cmmSources :: Lens' a [FilePath] - cmmSources = buildInfo . cmmSources - {-# INLINE cmmSources #-} - - cSources :: Lens' a [FilePath] - cSources = buildInfo . cSources - {-# INLINE cSources #-} - - cxxSources :: Lens' a [FilePath] - cxxSources = buildInfo . cxxSources - {-# INLINE cxxSources #-} - - jsSources :: Lens' a [FilePath] - jsSources = buildInfo . jsSources - {-# INLINE jsSources #-} - - hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir] - hsSourceDirs = buildInfo . hsSourceDirs - {-# INLINE hsSourceDirs #-} - - otherModules :: Lens' a [ModuleName] - otherModules = buildInfo . otherModules - {-# INLINE otherModules #-} - - virtualModules :: Lens' a [ModuleName] - virtualModules = buildInfo . virtualModules - {-# INLINE virtualModules #-} - - autogenModules :: Lens' a [ModuleName] - autogenModules = buildInfo . autogenModules - {-# INLINE autogenModules #-} - - defaultLanguage :: Lens' a (Maybe Language) - defaultLanguage = buildInfo . defaultLanguage - {-# INLINE defaultLanguage #-} - - otherLanguages :: Lens' a [Language] - otherLanguages = buildInfo . otherLanguages - {-# INLINE otherLanguages #-} - - defaultExtensions :: Lens' a [Extension] - defaultExtensions = buildInfo . defaultExtensions - {-# INLINE defaultExtensions #-} - - otherExtensions :: Lens' a [Extension] - otherExtensions = buildInfo . otherExtensions - {-# INLINE otherExtensions #-} - - oldExtensions :: Lens' a [Extension] - oldExtensions = buildInfo . oldExtensions - {-# INLINE oldExtensions #-} - - extraLibs :: Lens' a [String] - extraLibs = buildInfo . extraLibs - {-# INLINE extraLibs #-} - - extraGHCiLibs :: Lens' a [String] - extraGHCiLibs = buildInfo . extraGHCiLibs - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs :: Lens' a [String] - extraBundledLibs = buildInfo . extraBundledLibs - {-# INLINE extraBundledLibs #-} - - extraLibFlavours :: Lens' a [String] - extraLibFlavours = buildInfo . extraLibFlavours - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours :: Lens' a [String] - extraDynLibFlavours = buildInfo . extraDynLibFlavours - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs :: Lens' a [String] - extraLibDirs = buildInfo . extraLibDirs - {-# INLINE extraLibDirs #-} - - includeDirs :: Lens' a [FilePath] - includeDirs = buildInfo . includeDirs - {-# INLINE includeDirs #-} - - includes :: Lens' a [FilePath] - includes = buildInfo . includes - {-# INLINE includes #-} - - autogenIncludes :: Lens' a [FilePath] - autogenIncludes = buildInfo . autogenIncludes - {-# INLINE autogenIncludes #-} - - installIncludes :: Lens' a [FilePath] - installIncludes = buildInfo . installIncludes - {-# INLINE installIncludes #-} - - options :: Lens' a (PerCompilerFlavor [String]) - options = buildInfo . options - {-# INLINE options #-} - - profOptions :: Lens' a (PerCompilerFlavor [String]) - profOptions = buildInfo . profOptions - {-# INLINE profOptions #-} - - sharedOptions :: Lens' a (PerCompilerFlavor [String]) - sharedOptions = buildInfo . sharedOptions - {-# INLINE sharedOptions #-} - - staticOptions :: Lens' a (PerCompilerFlavor [String]) - staticOptions = buildInfo . staticOptions - {-# INLINE staticOptions #-} - - customFieldsBI :: Lens' a [(String,String)] - customFieldsBI = buildInfo . customFieldsBI - {-# INLINE customFieldsBI #-} - - targetBuildDepends :: Lens' a [Dependency] - targetBuildDepends = buildInfo . targetBuildDepends - {-# INLINE targetBuildDepends #-} - - mixins :: Lens' a [Mixin] - mixins = buildInfo . mixins - {-# INLINE mixins #-} - - -instance HasBuildInfo BuildInfo where - buildInfo = id - {-# INLINE buildInfo #-} - - buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s)) - {-# INLINE buildable #-} - - buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s)) - {-# INLINE buildTools #-} - - buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s)) - {-# INLINE buildToolDepends #-} - - cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s)) - {-# INLINE cppOptions #-} - - asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s)) - {-# INLINE asmOptions #-} - - cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s)) - {-# INLINE cmmOptions #-} - - ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) - {-# INLINE ccOptions #-} - - cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) - {-# INLINE cxxOptions #-} - - ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) - {-# INLINE ldOptions #-} - - hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s)) - {-# INLINE hsc2hsOptions #-} - - pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s)) - {-# INLINE pkgconfigDepends #-} - - frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) - {-# INLINE frameworks #-} - - extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s)) - {-# INLINE extraFrameworkDirs #-} - - asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s)) - {-# INLINE asmSources #-} - - cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s)) - {-# INLINE cmmSources #-} - - cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s)) - {-# INLINE cSources #-} - - cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s)) - {-# INLINE cxxSources #-} - - jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s)) - {-# INLINE jsSources #-} - - hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s)) - {-# INLINE hsSourceDirs #-} - - otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s)) - {-# INLINE otherModules #-} - - virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s)) - {-# INLINE virtualModules #-} - - autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s)) - {-# INLINE autogenModules #-} - - defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s)) - {-# INLINE defaultLanguage #-} - - otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s)) - {-# INLINE otherLanguages #-} - - defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s)) - {-# INLINE defaultExtensions #-} - - otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s)) - {-# INLINE otherExtensions #-} - - oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s)) - {-# INLINE oldExtensions #-} - - extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s)) - {-# INLINE extraLibs #-} - - extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s)) - {-# INLINE extraGHCiLibs #-} - - extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s)) - {-# INLINE extraBundledLibs #-} - - extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s)) - {-# INLINE extraLibFlavours #-} - - extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) - {-# INLINE extraDynLibFlavours #-} - - extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s)) - {-# INLINE extraLibDirs #-} - - includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) - {-# INLINE includeDirs #-} - - includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) - {-# INLINE includes #-} - - autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s)) - {-# INLINE autogenIncludes #-} - - installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s)) - {-# INLINE installIncludes #-} - - options f s = fmap (\x -> s { T.options = x }) (f (T.options s)) - {-# INLINE options #-} - - profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s)) - {-# INLINE profOptions #-} - - sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s)) - {-# INLINE sharedOptions #-} - - staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s)) - {-# INLINE staticOptions #-} - - customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s)) - {-# INLINE customFieldsBI #-} - - targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s)) - {-# INLINE targetBuildDepends #-} - - mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s)) - {-# INLINE mixins #-} - -class HasBuildInfos a where - traverseBuildInfos :: Traversal' a BuildInfo diff --git a/src/Distribution/Types/BuildType.hs b/src/Distribution/Types/BuildType.hs deleted file mode 100644 --- a/src/Distribution/Types/BuildType.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.BuildType ( - BuildType(..), - knownBuildTypes, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.CabalSpecVersion (CabalSpecVersion (..)) -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | The type of build system used by this package. -data BuildType - = Simple -- ^ calls @Distribution.Simple.defaultMain@ - | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, - -- which invokes @configure@ to generate additional build - -- information used by later phases. - | Make -- ^ calls @Distribution.Make.defaultMain@ - | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary BuildType -instance Structured BuildType -instance NFData BuildType where rnf = genericRnf - -knownBuildTypes :: [BuildType] -knownBuildTypes = [Simple, Configure, Make, Custom] - -instance Pretty BuildType where - pretty = Disp.text . show - -instance Parsec BuildType where - parsec = do - name <- P.munch1 isAlphaNum - case name of - "Simple" -> return Simple - "Configure" -> return Configure - "Custom" -> return Custom - "Make" -> return Make - "Default" -> do - v <- askCabalSpecVersion - if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests - then do - parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020" - return Custom - else fail ("unknown build-type: '" ++ name ++ "'") - _ -> fail ("unknown build-type: '" ++ name ++ "'") diff --git a/src/Distribution/Types/Component.hs b/src/Distribution/Types/Component.hs deleted file mode 100644 --- a/src/Distribution/Types/Component.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Component ( - Component(..), - foldComponent, - componentBuildInfo, - componentBuildable, - componentName, - partitionComponents, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Library -import Distribution.Types.ForeignLib -import Distribution.Types.Executable -import Distribution.Types.TestSuite -import Distribution.Types.Benchmark - -import Distribution.Types.ComponentName -import Distribution.Types.BuildInfo - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Component = CLib Library - | CFLib ForeignLib - | CExe Executable - | CTest TestSuite - | CBench Benchmark - deriving (Show, Eq, Read) - -instance Semigroup Component where - CLib l <> CLib l' = CLib (l <> l') - CFLib l <> CFLib l' = CFLib (l <> l') - CExe e <> CExe e' = CExe (e <> e') - CTest t <> CTest t' = CTest (t <> t') - CBench b <> CBench b' = CBench (b <> b') - _ <> _ = error "Cannot merge Component" - -instance L.HasBuildInfo Component where - buildInfo f (CLib l) = CLib <$> L.buildInfo f l - buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l - buildInfo f (CExe e) = CExe <$> L.buildInfo f e - buildInfo f (CTest t) = CTest <$> L.buildInfo f t - buildInfo f (CBench b) = CBench <$> L.buildInfo f b - -foldComponent :: (Library -> a) - -> (ForeignLib -> a) - -> (Executable -> a) - -> (TestSuite -> a) - -> (Benchmark -> a) - -> Component - -> a -foldComponent f _ _ _ _ (CLib lib) = f lib -foldComponent _ f _ _ _ (CFLib flib)= f flib -foldComponent _ _ f _ _ (CExe exe) = f exe -foldComponent _ _ _ f _ (CTest tst) = f tst -foldComponent _ _ _ _ f (CBench bch) = f bch - -componentBuildInfo :: Component -> BuildInfo -componentBuildInfo = - foldComponent libBuildInfo foreignLibBuildInfo buildInfo testBuildInfo benchmarkBuildInfo - --- | Is a component buildable (i.e., not marked with @buildable: False@)? --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 --- -componentBuildable :: Component -> Bool -componentBuildable = buildable . componentBuildInfo - -componentName :: Component -> ComponentName -componentName = - foldComponent (CLibName . libName) - (CFLibName . foreignLibName) - (CExeName . exeName) - (CTestName . testName) - (CBenchName . benchmarkName) - -partitionComponents - :: [Component] - -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark]) -partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[]) - where - fa x ~(a,b,c,d,e) = (x:a,b,c,d,e) - fb x ~(a,b,c,d,e) = (a,x:b,c,d,e) - fc x ~(a,b,c,d,e) = (a,b,x:c,d,e) - fd x ~(a,b,c,d,e) = (a,b,c,x:d,e) - fe x ~(a,b,c,d,e) = (a,b,c,d,x:e) diff --git a/src/Distribution/Types/ComponentId.hs b/src/Distribution/Types/ComponentId.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentId.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.ComponentId - ( ComponentId, unComponentId, mkComponentId - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (text) - --- | A 'ComponentId' uniquely identifies the transitive source --- code closure of a component (i.e. libraries, executables). --- --- For non-Backpack components, this corresponds one to one with --- the 'UnitId', which serves as the basis for install paths, --- linker symbols, etc. --- --- Use 'mkComponentId' and 'unComponentId' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype ComponentId = ComponentId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Construct a 'ComponentId' from a 'String' --- --- 'mkComponentId' is the inverse to 'unComponentId' --- --- Note: No validations are performed to ensure that the resulting --- 'ComponentId' is valid --- --- @since 2.0.0.2 -mkComponentId :: String -> ComponentId -mkComponentId = ComponentId . toShortText - --- | Convert 'ComponentId' to 'String' --- --- @since 2.0.0.2 -unComponentId :: ComponentId -> String -unComponentId (ComponentId s) = fromShortText s - --- | 'mkComponentId' --- --- @since 2.0.0.2 -instance IsString ComponentId where - fromString = mkComponentId - -instance Binary ComponentId -instance Structured ComponentId - -instance Pretty ComponentId where - pretty = text . unComponentId - -instance Parsec ComponentId where - parsec = mkComponentId `fmap` P.munch1 abi_char - where abi_char c = isAlphaNum c || c `elem` "-_." - -instance NFData ComponentId where - rnf = rnf . unComponentId diff --git a/src/Distribution/Types/ComponentInclude.hs b/src/Distribution/Types/ComponentInclude.hs --- a/src/Distribution/Types/ComponentInclude.hs +++ b/src/Distribution/Types/ComponentInclude.hs @@ -1,25 +1,25 @@ -module Distribution.Types.ComponentInclude ( - ComponentInclude(..), - ci_id, - ci_pkgid, - ci_cname -) where +module Distribution.Types.ComponentInclude + ( ComponentInclude (..) + , ci_id + , ci_pkgid + , ci_cname + ) where -import Distribution.Types.PackageId -import Distribution.Types.ComponentName import Distribution.Types.AnnotatedId +import Distribution.Types.ComponentName +import Distribution.Types.PackageId -- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId', -- the 'includeRequiresRn' is not so useful (because it -- includes the requirements renaming that is no longer -- needed); use 'ci_prov_renaming' instead. -data ComponentInclude id rn = ComponentInclude { - ci_ann_id :: AnnotatedId id, - ci_renaming :: rn, - -- | Did this come from an entry in @mixins@, or - -- was implicitly generated by @build-depends@? - ci_implicit :: Bool - } +data ComponentInclude id rn = ComponentInclude + { ci_ann_id :: AnnotatedId id + , ci_renaming :: rn + , ci_implicit :: Bool + -- ^ Did this come from an entry in @mixins@, or + -- was implicitly generated by @build-depends@? + } ci_id :: ComponentInclude id rn -> id ci_id = ann_id . ci_ann_id diff --git a/src/Distribution/Types/ComponentLocalBuildInfo.hs b/src/Distribution/Types/ComponentLocalBuildInfo.hs --- a/src/Distribution/Types/ComponentLocalBuildInfo.hs +++ b/src/Distribution/Types/ComponentLocalBuildInfo.hs @@ -1,129 +1,139 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.ComponentLocalBuildInfo ( - ComponentLocalBuildInfo(..), - componentIsIndefinite, - maybeComponentInstantiatedWith, +module Distribution.Types.ComponentLocalBuildInfo + ( ComponentLocalBuildInfo (..) + , componentIsIndefinite + , maybeComponentInstantiatedWith + , maybeComponentCompatPackageKey + , maybeComponentExposedModules ) where -import Prelude () import Distribution.Compat.Prelude import Distribution.ModuleName +import Prelude () import Distribution.Backpack import Distribution.Compat.Graph import Distribution.Types.ComponentId -import Distribution.Types.MungedPackageId -import Distribution.Types.UnitId import Distribution.Types.ComponentName -import Distribution.Types.MungedPackageName import Distribution.Types.ModuleRenaming +import Distribution.Types.MungedPackageId +import Distribution.Types.MungedPackageName +import Distribution.Types.UnitId import qualified Distribution.InstalledPackageInfo as Installed -- | The first five fields are common across all algebraic variants. data ComponentLocalBuildInfo - = LibComponentLocalBuildInfo { - -- | It would be very convenient to store the literal Library here, - -- but if we do that, it will get serialized (via the Binary) - -- instance twice. So instead we just provide the ComponentName, - -- which can be used to find the Component in the - -- PackageDescription. NB: eventually, this will NOT uniquely - -- identify the ComponentLocalBuildInfo. - componentLocalName :: ComponentName, - -- | The computed 'ComponentId' of this component. - componentComponentId :: ComponentId, - -- | The computed 'UnitId' which uniquely identifies this - -- component. Might be hashed. - componentUnitId :: UnitId, - -- | Is this an indefinite component (i.e. has unfilled holes)? - componentIsIndefinite_ :: Bool, - -- | How the component was instantiated - componentInstantiatedWith :: [(ModuleName, OpenModule)], - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(UnitId, MungedPackageId)], - -- | The set of packages that are brought into scope during - -- compilation, including a 'ModuleRenaming' which may used - -- to hide or rename modules. This is what gets translated into - -- @-package-id@ arguments. This is a modernized version of - -- 'componentPackageDeps', which is kept around for BC purposes. - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - -- | The internal dependencies which induce a graph on the - -- 'ComponentLocalBuildInfo' of this package. This does NOT - -- coincide with 'componentPackageDeps' because it ALSO records - -- 'build-tool' dependencies on executables. Maybe one day - -- @cabal-install@ will also handle these correctly too! - componentInternalDeps :: [UnitId], - -- | Compatibility "package key" that we pass to older versions of GHC. - componentCompatPackageKey :: String, - -- | Compatibility "package name" that we register this component as. - componentCompatPackageName :: MungedPackageName, - -- | A list of exposed modules (either defined in this component, - -- or reexported from another component.) - componentExposedModules :: [Installed.ExposedModule], - -- | Convenience field, specifying whether or not this is the - -- "public library" that has the same name as the package. - componentIsPublic :: Bool - } - -- TODO: refactor all these duplicates - | FLibComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | ExeComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - | TestComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - - } - | BenchComponentLocalBuildInfo { - componentLocalName :: ComponentName, - componentComponentId :: ComponentId, - componentUnitId :: UnitId, - componentPackageDeps :: [(UnitId, MungedPackageId)], - componentIncludes :: [(OpenUnitId, ModuleRenaming)], - componentExeDeps :: [UnitId], - componentInternalDeps :: [UnitId] - } - deriving (Generic, Read, Show, Typeable) + = LibComponentLocalBuildInfo + { componentLocalName :: ComponentName + -- ^ It would be very convenient to store the literal Library here, + -- but if we do that, it will get serialized (via the Binary) + -- instance twice. So instead we just provide the ComponentName, + -- which can be used to find the Component in the + -- PackageDescription. NB: eventually, this will NOT uniquely + -- identify the ComponentLocalBuildInfo. + , componentComponentId :: ComponentId + -- ^ The computed 'ComponentId' of this component. + , componentUnitId :: UnitId + -- ^ The computed 'UnitId' which uniquely identifies this + -- component. Might be hashed. + , componentIsIndefinite_ :: Bool + -- ^ Is this an indefinite component (i.e. has unfilled holes)? + , componentInstantiatedWith :: [(ModuleName, OpenModule)] + -- ^ How the component was instantiated + , componentPackageDeps :: [(UnitId, MungedPackageId)] + -- ^ Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + -- ^ The set of packages that are brought into scope during + -- compilation, including a 'ModuleRenaming' which may used + -- to hide or rename modules. This is what gets translated into + -- @-package-id@ arguments. This is a modernized version of + -- 'componentPackageDeps', which is kept around for BC purposes. + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + -- ^ The internal dependencies which induce a graph on the + -- 'ComponentLocalBuildInfo' of this package. This does NOT + -- coincide with 'componentPackageDeps' because it ALSO records + -- 'build-tool' dependencies on executables. Maybe one day + -- @cabal-install@ will also handle these correctly too! + , componentCompatPackageKey :: String + -- ^ Compatibility "package key" that we pass to older versions of GHC. + , componentCompatPackageName :: MungedPackageName + -- ^ Compatibility "package name" that we register this component as. + , componentExposedModules :: [Installed.ExposedModule] + -- ^ A list of exposed modules (either defined in this component, + -- or reexported from another component.) + , componentIsPublic :: Bool + -- ^ Convenience field, specifying whether or not this is the + -- "public library" that has the same name as the package. + } + | -- TODO: refactor all these duplicates + FLibComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | ExeComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | TestComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + | BenchComponentLocalBuildInfo + { componentLocalName :: ComponentName + , componentComponentId :: ComponentId + , componentUnitId :: UnitId + , componentPackageDeps :: [(UnitId, MungedPackageId)] + , componentIncludes :: [(OpenUnitId, ModuleRenaming)] + , componentExeDeps :: [UnitId] + , componentInternalDeps :: [UnitId] + } + deriving (Generic, Read, Show) instance Binary ComponentLocalBuildInfo instance Structured ComponentLocalBuildInfo instance IsNode ComponentLocalBuildInfo where - type Key ComponentLocalBuildInfo = UnitId - nodeKey = componentUnitId - nodeNeighbors = componentInternalDeps + type Key ComponentLocalBuildInfo = UnitId + nodeKey = componentUnitId + nodeNeighbors = componentInternalDeps componentIsIndefinite :: ComponentLocalBuildInfo -> Bool -componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b +componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b componentIsIndefinite _ = False maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)] maybeComponentInstantiatedWith - LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts + LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts maybeComponentInstantiatedWith _ = Nothing + +maybeComponentCompatPackageKey :: ComponentLocalBuildInfo -> Maybe String +maybeComponentCompatPackageKey + LibComponentLocalBuildInfo{componentCompatPackageKey = key} = Just key +maybeComponentCompatPackageKey _ = Nothing + +maybeComponentExposedModules :: ComponentLocalBuildInfo -> Maybe [Installed.ExposedModule] +maybeComponentExposedModules + LibComponentLocalBuildInfo{componentExposedModules = exposed} = Just exposed +maybeComponentExposedModules _ = Nothing diff --git a/src/Distribution/Types/ComponentName.hs b/src/Distribution/Types/ComponentName.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentName.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ComponentName ( - ComponentName(..), - showComponentName, - componentNameStanza, - componentNameString, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Types.LibraryName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- Libraries live in a separate namespace, so must distinguish -data ComponentName = CLibName LibraryName - | CFLibName UnqualComponentName - | CExeName UnqualComponentName - | CTestName UnqualComponentName - | CBenchName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable) - -instance Binary ComponentName -instance Structured ComponentName - --- Build-target-ish syntax -instance Pretty ComponentName where - pretty (CLibName lib) = prettyLibraryNameComponent lib - pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str - pretty (CExeName str) = Disp.text "exe:" <<>> pretty str - pretty (CTestName str) = Disp.text "test:" <<>> pretty str - pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str - -instance Parsec ComponentName where - -- note: this works as lib/flib/... all start with different character! - parsec = parseComposite <|> parseLib - where - parseLib = CLibName <$> parsecLibraryNameComponent - parseComposite = do - ctor <- P.choice - [ P.string "flib:" >> return CFLibName - , P.string "exe:" >> return CExeName - , P.string "bench:" >> return CBenchName - , P.string "test:" >> return CTestName - ] - ctor <$> parsec - -showComponentName :: ComponentName -> String -showComponentName (CLibName lib) = showLibraryName lib -showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'" -showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'" -showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'" -showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'" - -componentNameStanza :: ComponentName -> String -componentNameStanza (CLibName lib) = libraryNameStanza lib -componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name -componentNameStanza (CExeName name) = "executable " ++ prettyShow name -componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name -componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name - --- | This gets the underlying unqualified component name. In fact, it is --- guaranteed to uniquely identify a component, returning --- @Nothing@ if the 'ComponentName' was for the public --- library. -componentNameString :: ComponentName -> Maybe UnqualComponentName -componentNameString (CLibName lib) = libraryNameString lib -componentNameString (CFLibName n) = Just n -componentNameString (CExeName n) = Just n -componentNameString (CTestName n) = Just n -componentNameString (CBenchName n) = Just n diff --git a/src/Distribution/Types/ComponentRequestedSpec.hs b/src/Distribution/Types/ComponentRequestedSpec.hs deleted file mode 100644 --- a/src/Distribution/Types/ComponentRequestedSpec.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ComponentRequestedSpec ( - -- $buildable_vs_enabled_components - - ComponentRequestedSpec(..), - ComponentDisabledReason(..), - - defaultComponentRequestedSpec, - componentNameRequested, - - componentEnabled, - componentDisabledReason, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Component -- TODO: maybe remove me? -import Distribution.Types.ComponentName - -import Distribution.Pretty (prettyShow) - --- $buildable_vs_enabled_components --- #buildable_vs_enabled_components# --- --- = Note: Buildable versus requested versus enabled components --- What's the difference between a buildable component (ala --- 'componentBuildable'), a requested component --- (ala 'componentNameRequested'), and an enabled component (ala --- 'componentEnabled')? --- --- A component is __buildable__ if, after resolving flags and --- conditionals, there is no @buildable: False@ property in it. --- This is a /static/ property that arises from the --- Cabal file and the package description flattening; once we have --- a 'PackageDescription' buildability is known. --- --- A component is __requested__ if a user specified, via a --- the flags and arguments passed to configure, that it should be --- built. E.g., @--enable-tests@ or @--enable-benchmarks@ request --- all tests and benchmarks, if they are provided. What is requested --- can be read off directly from 'ComponentRequestedSpec'. A requested --- component is not always buildable; e.g., a user may @--enable-tests@ --- but one of the test suites may have @buildable: False@. --- --- A component is __enabled__ if it is BOTH buildable --- and requested. Once we have a 'LocalBuildInfo', whether or not a --- component is enabled is known. --- --- Generally speaking, most Cabal API code cares if a component --- is enabled. (For example, if you want to run a preprocessor on each --- component prior to building them, you want to run this on each --- /enabled/ component.) --- --- Note that post-configuration, you will generally not see a --- non-buildable 'Component'. This is because 'flattenPD' will drop --- any such components from 'PackageDescription'. See #3858 for --- an example where this causes problems. - --- | Describes what components are enabled by user-interaction. --- See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -data ComponentRequestedSpec - = ComponentRequestedSpec { testsRequested :: Bool - , benchmarksRequested :: Bool } - | OneComponentRequestedSpec ComponentName - deriving (Generic, Read, Show, Eq, Typeable) - -instance Binary ComponentRequestedSpec -instance Structured ComponentRequestedSpec - --- | The default set of enabled components. Historically tests and --- benchmarks are NOT enabled by default. --- --- @since 2.0.0.2 -defaultComponentRequestedSpec :: ComponentRequestedSpec -defaultComponentRequestedSpec = ComponentRequestedSpec False False - --- | Is this component enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentEnabled :: ComponentRequestedSpec -> Component -> Bool -componentEnabled enabled = isNothing . componentDisabledReason enabled - --- | Is this component name enabled? See also this note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components". --- --- @since 2.0.0.2 -componentNameRequested :: ComponentRequestedSpec -> ComponentName -> Bool -componentNameRequested enabled = isNothing . componentNameNotRequestedReason enabled - --- | Is this component disabled, and if so, why? --- --- @since 2.0.0.2 -componentDisabledReason :: ComponentRequestedSpec -> Component - -> Maybe ComponentDisabledReason -componentDisabledReason enabled comp - | not (componentBuildable comp) = Just DisabledComponent - | otherwise = componentNameNotRequestedReason enabled (componentName comp) - --- | Is this component name disabled, and if so, why? --- --- @since 2.0.0.2 -componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName - -> Maybe ComponentDisabledReason -componentNameNotRequestedReason - ComponentRequestedSpec{ testsRequested = False } (CTestName _) - = Just DisabledAllTests -componentNameNotRequestedReason - ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _) - = Just DisabledAllBenchmarks -componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing -componentNameNotRequestedReason (OneComponentRequestedSpec cname) c - | c == cname = Nothing - | otherwise = Just (DisabledAllButOne (prettyShow cname)) - --- | A reason explaining why a component is disabled. --- --- @since 2.0.0.2 -data ComponentDisabledReason = DisabledComponent - | DisabledAllTests - | DisabledAllBenchmarks - | DisabledAllButOne String diff --git a/src/Distribution/Types/CondTree.hs b/src/Distribution/Types/CondTree.hs deleted file mode 100644 --- a/src/Distribution/Types/CondTree.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.CondTree ( - CondTree(..), - CondBranch(..), - condIfThen, - condIfThenElse, - mapCondTree, - mapTreeConstrs, - mapTreeConds, - mapTreeData, - traverseCondTreeV, - traverseCondBranchV, - traverseCondTreeC, - traverseCondBranchC, - extractCondition, - simplifyCondTree, - ignoreConditions, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Condition - -import qualified Distribution.Compat.Lens as L - - --- | A 'CondTree' is used to represent the conditional structure of --- a Cabal file, reflecting a syntax element subject to constraints, --- and then any number of sub-elements which may be enabled subject --- to some condition. Both @a@ and @c@ are usually 'Monoid's. --- --- To be more concrete, consider the following fragment of a @Cabal@ --- file: --- --- @ --- build-depends: base >= 4.0 --- if flag(extra) --- build-depends: base >= 4.2 --- @ --- --- One way to represent this is to have @'CondTree' 'ConfVar' --- ['Dependency'] 'BuildInfo'@. Here, 'condTreeData' represents --- the actual fields which are not behind any conditional, while --- 'condTreeComponents' recursively records any further fields --- which are behind a conditional. 'condTreeConstraints' records --- the constraints (in this case, @base >= 4.0@) which would --- be applied if you use this syntax; in general, this is --- derived off of 'targetBuildInfo' (perhaps a good refactoring --- would be to convert this into an opaque type, with a smart --- constructor that pre-computes the dependencies.) --- -data CondTree v c a = CondNode - { condTreeData :: a - , condTreeConstraints :: c - , condTreeComponents :: [CondBranch v c a] - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable) - -instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondTree v c a) where rnf = genericRnf - --- | A 'CondBranch' represents a conditional branch, e.g., @if --- flag(foo)@ on some syntax @a@. It also has an optional false --- branch. --- -data CondBranch v c a = CondBranch - { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTree v c a - , condBranchIfFalse :: Maybe (CondTree v c a) - } - deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable) - --- This instance is written by hand because GHC 8.0.1/8.0.2 infinite --- loops when trying to derive it with optimizations. See --- https://gitlab.haskell.org/ghc/ghc/-/issues/13056 -instance Foldable (CondBranch v c) where - foldMap f (CondBranch _ c Nothing) = foldMap f c - foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a - -instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a) -instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a) -instance (NFData v, NFData c, NFData a) => NFData (CondBranch v c a) where rnf = genericRnf - -condIfThen :: Condition v -> CondTree v c a -> CondBranch v c a -condIfThen c t = CondBranch c t Nothing - -condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a -condIfThenElse c t e = CondBranch c t (Just e) - -mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) - -> CondTree v c a -> CondTree w d b -mapCondTree fa fc fcnd (CondNode a c ifs) = - CondNode (fa a) (fc c) (map g ifs) - where - g (CondBranch cnd t me) - = CondBranch (fcnd cnd) - (mapCondTree fa fc fcnd t) - (fmap (mapCondTree fa fc fcnd) me) - -mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a -mapTreeConstrs f = mapCondTree id f id - -mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a -mapTreeConds f = mapCondTree id id f - -mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b -mapTreeData f = mapCondTree f id id - --- | @@Traversal@@ for the variables -traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w -traverseCondTreeV f (CondNode a c ifs) = - CondNode a c <$> traverse (traverseCondBranchV f) ifs - --- | @@Traversal@@ for the variables -traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w -traverseCondBranchV f (CondBranch cnd t me) = CondBranch - <$> traverse f cnd - <*> traverseCondTreeV f t - <*> traverse (traverseCondTreeV f) me - --- | @@Traversal@@ for the aggregated constraints -traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d -traverseCondTreeC f (CondNode a c ifs) = - CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs - --- | @@Traversal@@ for the aggregated constraints -traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d -traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd - <$> traverseCondTreeC f t - <*> traverse (traverseCondTreeC f) me - - --- | Extract the condition matched by the given predicate from a cond tree. --- --- We use this mainly for extracting buildable conditions (see the Note in --- Distribution.PackageDescription.Configuration), but the function is in fact --- more general. -extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v -extractCondition p = go - where - go (CondNode x _ cs) | not (p x) = Lit False - | otherwise = goList cs - - goList [] = Lit True - goList (CondBranch c t e : cs) = - let - ct = go t - ce = maybe (Lit True) go e - in - ((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs - --- | Flattens a CondTree using a partial flag assignment. When a condition --- cannot be evaluated, both branches are ignored. -simplifyCondTree :: (Semigroup a, Semigroup d) => - (v -> Either v Bool) - -> CondTree v d a - -> (d, a) -simplifyCondTree env (CondNode a d ifs) = - foldl (<>) (d, a) $ mapMaybe simplifyIf ifs - where - simplifyIf (CondBranch cnd t me) = - case simplifyCondition cnd env of - (Lit True, _) -> Just $ simplifyCondTree env t - (Lit False, _) -> fmap (simplifyCondTree env) me - _ -> Nothing - --- | Flatten a CondTree. This will resolve the CondTree by taking all --- possible paths into account. Note that since branches represent exclusive --- choices this may not result in a \"sane\" result. -ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c) -ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs - where f (CondBranch _ t me) = ignoreConditions t - : maybeToList (fmap ignoreConditions me) diff --git a/src/Distribution/Types/Condition.hs b/src/Distribution/Types/Condition.hs deleted file mode 100644 --- a/src/Distribution/Types/Condition.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Condition ( - Condition(..), - cNot, - cAnd, - cOr, - simplifyCondition, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- | A boolean expression parameterized over the variable type used. -data Condition c = Var c - | Lit Bool - | CNot (Condition c) - | COr (Condition c) (Condition c) - | CAnd (Condition c) (Condition c) - deriving (Show, Eq, Typeable, Data, Generic) - --- | Boolean negation of a 'Condition' value. -cNot :: Condition a -> Condition a -cNot (Lit b) = Lit (not b) -cNot (CNot c) = c -cNot c = CNot c - --- | Boolean AND of two 'Condtion' values. -cAnd :: Condition a -> Condition a -> Condition a -cAnd (Lit False) _ = Lit False -cAnd _ (Lit False) = Lit False -cAnd (Lit True) x = x -cAnd x (Lit True) = x -cAnd x y = CAnd x y - --- | Boolean OR of two 'Condition' values. -cOr :: Eq v => Condition v -> Condition v -> Condition v -cOr (Lit True) _ = Lit True -cOr _ (Lit True) = Lit True -cOr (Lit False) x = x -cOr x (Lit False) = x -cOr c (CNot d) - | c == d = Lit True -cOr (CNot c) d - | c == d = Lit True -cOr x y = COr x y - -instance Functor Condition where - f `fmap` Var c = Var (f c) - _ `fmap` Lit c = Lit c - f `fmap` CNot c = CNot (fmap f c) - f `fmap` COr c d = COr (fmap f c) (fmap f d) - f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d) - -instance Foldable Condition where - f `foldMap` Var c = f c - _ `foldMap` Lit _ = mempty - f `foldMap` CNot c = foldMap f c - f `foldMap` COr c d = foldMap f c `mappend` foldMap f d - f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d - -instance Traversable Condition where - f `traverse` Var c = Var `fmap` f c - _ `traverse` Lit c = pure $ Lit c - f `traverse` CNot c = CNot `fmap` traverse f c - f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d - f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d - -instance Applicative Condition where - pure = Var - (<*>) = ap - -instance Monad Condition where - return = pure - -- Terminating cases - (>>=) (Lit x) _ = Lit x - (>>=) (Var x) f = f x - -- Recursing cases - (>>=) (CNot x ) f = CNot (x >>= f) - (>>=) (COr x y) f = COr (x >>= f) (y >>= f) - (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f) - -instance Monoid (Condition a) where - mempty = Lit False - mappend = (<>) - -instance Semigroup (Condition a) where - (<>) = COr - -instance Alternative Condition where - empty = mempty - (<|>) = mappend - -instance MonadPlus Condition where - mzero = mempty - mplus = mappend - -instance Binary c => Binary (Condition c) -instance Structured c => Structured (Condition c) -instance NFData c => NFData (Condition c) where rnf = genericRnf - --- | Simplify the condition and return its free variables. -simplifyCondition :: Condition c - -> (c -> Either d Bool) -- ^ (partial) variable assignment - -> (Condition d, [d]) -simplifyCondition cond i = fv . walk $ cond - where - walk cnd = case cnd of - Var v -> either Var Lit (i v) - Lit b -> Lit b - CNot c -> case walk c of - Lit True -> Lit False - Lit False -> Lit True - c' -> CNot c' - COr c d -> case (walk c, walk d) of - (Lit False, d') -> d' - (Lit True, _) -> Lit True - (c', Lit False) -> c' - (_, Lit True) -> Lit True - (c',d') -> COr c' d' - CAnd c d -> case (walk c, walk d) of - (Lit False, _) -> Lit False - (Lit True, d') -> d' - (_, Lit False) -> Lit False - (c', Lit True) -> c' - (c',d') -> CAnd c' d' - -- gather free vars - fv c = (c, fv' c) - fv' c = case c of - Var v -> [v] - Lit _ -> [] - CNot c' -> fv' c' - COr c1 c2 -> fv' c1 ++ fv' c2 - CAnd c1 c2 -> fv' c1 ++ fv' c2 diff --git a/src/Distribution/Types/ConfVar.hs b/src/Distribution/Types/ConfVar.hs deleted file mode 100644 --- a/src/Distribution/Types/ConfVar.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ConfVar ( - ConfVar(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Flag -import Distribution.Types.VersionRange -import Distribution.Compiler -import Distribution.System - --- | A @ConfVar@ represents the variable type used. -data ConfVar = OS OS - | Arch Arch - | PackageFlag FlagName - | Impl CompilerFlavor VersionRange - deriving (Eq, Show, Typeable, Data, Generic) - -instance Binary ConfVar -instance Structured ConfVar - -instance NFData ConfVar where rnf = genericRnf diff --git a/src/Distribution/Types/Dependency.hs b/src/Distribution/Types/Dependency.hs deleted file mode 100644 --- a/src/Distribution/Types/Dependency.hs +++ /dev/null @@ -1,179 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Dependency - ( Dependency(..) - , mkDependency - , depPkgName - , depVerRange - , depLibraries - , simplifyDependency - , mainLibSet - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.VersionRange (isAnyVersionLight) -import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) - -import Distribution.CabalSpecVersion -import Distribution.Compat.CharParsing (char, spaces) -import Distribution.Compat.Parsing (between, option) -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on a source package (API) --- --- /Invariant:/ package name does not appear as 'LSubLibName' in --- set of library names. --- -data Dependency = Dependency - PackageName - VersionRange - (NonEmptySet LibraryName) - -- ^ The set of libraries required from the package. - -- Only the selected libraries will be built. - -- It does not affect the cabal-install solver yet. - deriving (Generic, Read, Show, Eq, Typeable, Data) - -depPkgName :: Dependency -> PackageName -depPkgName (Dependency pn _ _) = pn - -depVerRange :: Dependency -> VersionRange -depVerRange (Dependency _ vr _) = vr - -depLibraries :: Dependency -> NonEmptySet LibraryName -depLibraries (Dependency _ _ cs) = cs - --- | Smart constructor of 'Dependency'. --- --- If 'PackageName' is appears as 'LSubLibName' in a set of sublibraries, --- it is automatically converted to 'LMainLibName'. --- --- @since 3.4.0.0 --- -mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency -mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) - where - pn' = packageNameToUnqualComponentName pn - - conv l@LMainLibName = l - conv l@(LSubLibName ln) | ln == pn' = LMainLibName - | otherwise = l - -instance Binary Dependency -instance Structured Dependency -instance NFData Dependency where rnf = genericRnf - --- | --- --- >>> prettyShow $ Dependency "pkg" anyVersion mainLibSet --- "pkg" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib") mainLibSet --- "pkg:{pkg, sublib}" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.singleton (LSubLibName "sublib") --- "pkg:sublib" --- --- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a") --- "pkg:{sublib-a, sublib-b}" --- -instance Pretty Dependency where - pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver - where - -- TODO: change to isAnyVersion after #6736 - pver | isAnyVersionLight ver = PP.empty - | otherwise = pretty ver - - withSubLibs doc = case NES.toList sublibs of - [LMainLibName] -> doc - [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq - _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs - - prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs - - prettySublib LMainLibName = PP.text $ unPackageName name - prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un - --- | --- --- >>> simpleParsec "mylib:sub" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| []))) --- --- >>> simpleParsec "mylib:{sub1,sub2}" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 }" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ sub1 , sub2 } ^>= 42" :: Maybe Dependency --- Just (Dependency (PackageName "mylib") (MajorBoundVersion (mkVersion [42])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub1") :| [LSubLibName (UnqualComponentName "sub2")]))) --- --- >>> simpleParsec "mylib:{ } ^>= 42" :: Maybe Dependency --- Nothing --- --- >>> traverse_ print (map simpleParsec ["mylib:mylib", "mylib:{mylib}", "mylib:{mylib,sublib}" ] :: [Maybe Dependency]) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| []))) --- Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LMainLibName :| [LSubLibName (UnqualComponentName "sublib")]))) --- --- Spaces around colon are not allowed: --- --- >>> map simpleParsec ["mylib: sub", "mylib :sub", "mylib: {sub1,sub2}", "mylib :{sub1,sub2}"] :: [Maybe Dependency] --- [Nothing,Nothing,Nothing,Nothing] --- --- Sublibrary syntax is accepted since @cabal-version: 3.0@ --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] --- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] --- -instance Parsec Dependency where - parsec = do - name <- parsec - - libs <- option mainLibSet $ do - _ <- char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - NES.singleton <$> parseLib <|> parseMultipleLibs - - spaces -- https://github.com/haskell/cabal/issues/5846 - - ver <- parsec <|> pure anyVersion - return $ mkDependency name ver libs - where - parseLib = LSubLibName <$> parsec - parseMultipleLibs = between - (char '{' *> spaces) - (spaces *> char '}') - (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib) - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_0) $ fail $ unwords - [ "Sublibrary dependency syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if you are depending on an internal library, you can write" - , "directly the library name as it were a package." - ] - --- | Library set with main library. --- --- @since 3.4.0.0 -mainLibSet :: NonEmptySet LibraryName -mainLibSet = NES.singleton LMainLibName - --- | Simplify the 'VersionRange' expression in a 'Dependency'. --- See 'simplifyVersionRange'. --- -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range comps) = - Dependency name (simplifyVersionRange range) comps diff --git a/src/Distribution/Types/DependencyMap.hs b/src/Distribution/Types/DependencyMap.hs deleted file mode 100644 --- a/src/Distribution/Types/DependencyMap.hs +++ /dev/null @@ -1,57 +0,0 @@ -module Distribution.Types.DependencyMap ( - DependencyMap, - toDepMap, - fromDepMap, - constrainBy, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.PackageVersionConstraint -import Distribution.Version - -import qualified Data.Map.Lazy as Map - --- | A map of dependencies. Newtyped since the default monoid instance is not --- appropriate. The monoid instance uses 'intersectVersionRanges'. -newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) } - deriving (Show, Read) - -instance Monoid DependencyMap where - mempty = DependencyMap Map.empty - mappend = (<>) - -instance Semigroup DependencyMap where - (DependencyMap a) <> (DependencyMap b) = - DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b) - -intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) - -> (VersionRange, NonEmptySet LibraryName) -intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) = - (intersectVersionRanges va vb, ca <> cb) - -toDepMap :: [Dependency] -> DependencyMap -toDepMap ds = - DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ] - -fromDepMap :: DependencyMap -> [Dependency] -fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ] - --- Apply extra constraints to a dependency map. --- Combines dependencies where the result will only contain keys from the left --- (first) map. If a key also exists in the right map, both constraints will --- be intersected. -constrainBy - :: DependencyMap - -> [PackageVersionConstraint] - -> DependencyMap -constrainBy = foldl' tightenConstraint where - tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $ - case Map.lookup pn l of - Nothing -> l - Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l diff --git a/src/Distribution/Types/DumpBuildInfo.hs b/src/Distribution/Types/DumpBuildInfo.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/DumpBuildInfo.hs @@ -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 diff --git a/src/Distribution/Types/ExeDependency.hs b/src/Distribution/Types/ExeDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/ExeDependency.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExeDependency - ( ExeDependency(..) - , qualifiedExeName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version (VersionRange, anyVersion, isAnyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | Describes a dependency on an executable from a package --- -data ExeDependency = ExeDependency - PackageName - UnqualComponentName -- name of executable component of package - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary ExeDependency -instance Structured ExeDependency -instance NFData ExeDependency where rnf = genericRnf - -instance Pretty ExeDependency where - pretty (ExeDependency name exe ver) = - pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver - where - pver | isAnyVersion ver = PP.empty - | otherwise = pretty ver - --- | --- --- Examples --- --- >>> simpleParsec "happy:happy" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "happy:happy >= 1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy:happy>=1.19.12" :: Maybe ExeDependency --- Just (ExeDependency (PackageName "happy") (UnqualComponentName "happy") (OrLaterVersion (mkVersion [1,19,12]))) --- --- >>> simpleParsec "happy : happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy: happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- --- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency --- Nothing --- -instance Parsec ExeDependency where - parsec = do - name <- parsec - _ <- P.char ':' - exe <- lexemeParsec - ver <- parsec <|> pure anyVersion - return (ExeDependency name exe ver) - -qualifiedExeName :: ExeDependency -> ComponentName -qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn diff --git a/src/Distribution/Types/Executable.hs b/src/Distribution/Types/Executable.hs deleted file mode 100644 --- a/src/Distribution/Types/Executable.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Executable ( - Executable(..), - emptyExecutable, - exeModules, - exeModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName -import Distribution.Types.ExecutableScope -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Executable = Executable { - exeName :: UnqualComponentName, - modulePath :: FilePath, - exeScope :: ExecutableScope, - buildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo Executable where - buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) - -instance Binary Executable -instance Structured Executable -instance NFData Executable where rnf = genericRnf - -instance Monoid Executable where - mempty = gmempty - mappend = (<>) - -instance Semigroup Executable where - a <> b = Executable{ - exeName = combine' exeName, - modulePath = combine modulePath, - exeScope = combine exeScope, - buildInfo = combine buildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyExecutable :: Executable -emptyExecutable = mempty - --- | Get all the module names from an exe -exeModules :: Executable -> [ModuleName] -exeModules exe = otherModules (buildInfo exe) - --- | Get all the auto generated module names from an exe --- This are a subset of 'exeModules'. -exeModulesAutogen :: Executable -> [ModuleName] -exeModulesAutogen exe = autogenModules (buildInfo exe) diff --git a/src/Distribution/Types/Executable/Lens.hs b/src/Distribution/Types/Executable/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Executable/Lens.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Distribution.Types.Executable.Lens ( - Executable, - module Distribution.Types.Executable.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Executable (Executable) -import Distribution.Types.ExecutableScope (ExecutableScope) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.Executable as T - -exeName :: Lens' Executable UnqualComponentName -exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) -{-# INLINE exeName #-} - -modulePath :: Lens' Executable String -modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) -{-# INLINE modulePath #-} - -exeScope :: Lens' Executable ExecutableScope -exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s)) -{-# INLINE exeScope #-} - -exeBuildInfo :: Lens' Executable BuildInfo -exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s)) -{-# INLINE exeBuildInfo #-} diff --git a/src/Distribution/Types/ExecutableScope.hs b/src/Distribution/Types/ExecutableScope.hs deleted file mode 100644 --- a/src/Distribution/Types/ExecutableScope.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ExecutableScope ( - ExecutableScope(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExecutableScope = ExecutablePublic - | ExecutablePrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ExecutableScope where - pretty ExecutablePublic = Disp.text "public" - pretty ExecutablePrivate = Disp.text "private" - -instance Parsec ExecutableScope where - parsec = P.try pub <|> pri where - pub = ExecutablePublic <$ P.string "public" - pri = ExecutablePrivate <$ P.string "private" - -instance Binary ExecutableScope -instance Structured ExecutableScope -instance NFData ExecutableScope where rnf = genericRnf - --- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True' -instance Semigroup ExecutableScope where - ExecutablePublic <> x = x - x@ExecutablePrivate <> _ = x - --- | 'mempty' = 'ExecutablePublic' -instance Monoid ExecutableScope where - mempty = ExecutablePublic - mappend = (<>) diff --git a/src/Distribution/Types/ExposedModule.hs b/src/Distribution/Types/ExposedModule.hs deleted file mode 100644 --- a/src/Distribution/Types/ExposedModule.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.ExposedModule where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ExposedModule - = ExposedModule { - exposedName :: ModuleName, - exposedReexport :: Maybe OpenModule - } - deriving (Eq, Generic, Read, Show, Typeable) - -instance Pretty ExposedModule where - pretty (ExposedModule m reexport) = - Disp.hsep [ pretty m - , case reexport of - Just m' -> Disp.hsep [Disp.text "from", pretty m'] - Nothing -> Disp.empty - ] - -instance Parsec ExposedModule where - parsec = do - m <- parsecMaybeQuoted parsec - P.spaces - - reexport <- P.optional $ do - _ <- P.string "from" - P.skipSpaces1 - parsec - - return (ExposedModule m reexport) - -instance Binary ExposedModule -instance Structured ExposedModule -instance NFData ExposedModule where rnf = genericRnf diff --git a/src/Distribution/Types/Flag.hs b/src/Distribution/Types/Flag.hs deleted file mode 100644 --- a/src/Distribution/Types/Flag.hs +++ /dev/null @@ -1,346 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.Flag ( - -- * Package flag - PackageFlag(..), - emptyFlag, - -- * Flag name - FlagName, - mkFlagName, - unFlagName, - -- * Flag assignment - FlagAssignment, - mkFlagAssignment, - unFlagAssignment, - lookupFlagAssignment, - insertFlagAssignment, - diffFlagAssignment, - findDuplicateFlagAssignments, - nullFlagAssignment, - showFlagValue, - dispFlagAssignment, - showFlagAssignment, - parsecFlagAssignment, - parsecFlagAssignmentNonEmpty, - -- ** Legacy formats - legacyShowFlagAssignment, - legacyShowFlagAssignment', - legacyParsecFlagAssignment, - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Distribution.Utils.Generic (lowercase) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.CharParsing as P - --- ----------------------------------------------------------------------------- --- The Flag' type - --- | A flag can represent a feature to be included, or a way of linking --- a target against its dependencies, or in fact whatever you can think of. -data PackageFlag = MkPackageFlag - { flagName :: FlagName - , flagDescription :: String - , flagDefault :: Bool - , flagManual :: Bool - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Binary PackageFlag -instance Structured PackageFlag -instance NFData PackageFlag where rnf = genericRnf - --- | A 'PackageFlag' initialized with default parameters. -emptyFlag :: FlagName -> PackageFlag -emptyFlag name = MkPackageFlag - { flagName = name - , flagDescription = "" - , flagDefault = True - , flagManual = False - } - --- | A 'FlagName' is the name of a user-defined configuration flag --- --- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype FlagName = FlagName ShortText - deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData) - --- | Construct a 'FlagName' from a 'String' --- --- 'mkFlagName' is the inverse to 'unFlagName' --- --- Note: No validations are performed to ensure that the resulting --- 'FlagName' is valid --- --- @since 2.0.0.2 -mkFlagName :: String -> FlagName -mkFlagName = FlagName . toShortText - --- | 'mkFlagName' --- --- @since 2.0.0.2 -instance IsString FlagName where - fromString = mkFlagName - --- | Convert 'FlagName' to 'String' --- --- @since 2.0.0.2 -unFlagName :: FlagName -> String -unFlagName (FlagName s) = fromShortText s - -instance Binary FlagName -instance Structured FlagName - -instance Pretty FlagName where - pretty = Disp.text . unFlagName - -instance Parsec FlagName where - -- Note: we don't check that FlagName doesn't have leading dash, - -- cabal check will do that. - parsec = mkFlagName . lowercase <$> parsec' - where - parsec' = (:) <$> lead <*> rest - lead = P.satisfy (\c -> isAlphaNum c || c == '_') - rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-') - --- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to --- 'Bool' flag values. It represents the flags chosen by the user or --- discovered during configuration. For example @--flags=foo --flags=-bar@ --- becomes @[("foo", True), ("bar", False)]@ --- --- TODO: Why we record the multiplicity of the flag? --- -newtype FlagAssignment - = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) } - deriving (Binary, Generic, NFData, Typeable) - -instance Structured FlagAssignment - -instance Eq FlagAssignment where - (==) (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 == fmap snd m2 - -instance Ord FlagAssignment where - compare (FlagAssignment m1) (FlagAssignment m2) - = fmap snd m1 `compare` fmap snd m2 - --- | Combines pairs of values contained in the 'FlagAssignment' Map. --- --- The last flag specified takes precedence, and we record the number --- of times we have seen the flag. --- -combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool) -combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2) - --- The 'Semigroup' instance currently is right-biased. --- --- If duplicate flags are specified, we want the last flag specified to --- take precedence and we want to know how many times the flag has been --- specified so that we have the option of warning the user about --- supplying duplicate flags. -instance Semigroup FlagAssignment where - (<>) (FlagAssignment m1) (FlagAssignment m2) - = FlagAssignment (Map.unionWith combineFlagValues m1 m2) - -instance Monoid FlagAssignment where - mempty = FlagAssignment Map.empty - mappend = (<>) - --- | Construct a 'FlagAssignment' from a list of flag/value pairs. --- --- If duplicate flags occur in the input list, the later entries --- in the list will take precedence. --- --- @since 2.2.0 -mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment -mkFlagAssignment = - FlagAssignment . - Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b))) - --- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs. --- --- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @ --- --- @since 2.2.0 -unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)] -unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment - --- | Test whether 'FlagAssignment' is empty. --- --- @since 2.2.0 -nullFlagAssignment :: FlagAssignment -> Bool -nullFlagAssignment = Map.null . getFlagAssignment - --- | Lookup the value for a flag --- --- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'. --- --- @since 2.2.0 -lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool -lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment - --- | Insert or update the boolean value of a flag. --- --- If the flag is already present in the 'FlagAssigment', the --- value will be updated and the fact that multiple values have --- been provided for that flag will be recorded so that a --- warning can be generated later on. --- --- @since 2.2.0 -insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment --- TODO: this currently just shadows prior values for an existing --- flag; rather than enforcing uniqueness at construction, it's --- verified later on via `D.C.Dependency.configuredPackageProblems` -insertFlagAssignment flag val = - FlagAssignment . - Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment - --- | Remove all flag-assignments from the first 'FlagAssignment' that --- are contained in the second 'FlagAssignment' --- --- NB/TODO: This currently only removes flag assignments which also --- match the value assignment! We should review the code which uses --- this operation to figure out if this it's not enough to only --- compare the flagnames without the values. --- --- @since 2.2.0 -diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment -diffFlagAssignment fa1 fa2 = FlagAssignment - (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2)) - --- | Find the 'FlagName's that have been listed more than once. --- --- @since 2.2.0 -findDuplicateFlagAssignments :: FlagAssignment -> [FlagName] -findDuplicateFlagAssignments = - Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment - --- | @since 2.2.0 -instance Read FlagAssignment where - readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ] - --- | @since 2.2.0 -instance Show FlagAssignment where - showsPrec p (FlagAssignment xs) = showsPrec p xs - --- | String representation of a flag-value pair. -showFlagValue :: (FlagName, Bool) -> String -showFlagValue (f, True) = '+' : unFlagName f -showFlagValue (f, False) = '-' : unFlagName f - --- | @since 3.4.0.0 -instance Pretty FlagAssignment where - pretty = dispFlagAssignment - --- | --- --- >>> simpleParsec "" :: Maybe FlagAssignment --- Just (fromList []) --- --- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment --- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))]) --- --- >>> simpleParsec "-none -any" :: Maybe FlagAssignment --- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))]) --- --- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment --- Just (fromList [(FlagName "foo",(4,True))]) --- --- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment --- Nothing --- --- @since 3.4.0.0 --- -instance Parsec FlagAssignment where - parsec = parsecFlagAssignment - --- | Pretty-prints a flag assignment. -dispFlagAssignment :: FlagAssignment -> Disp.Doc -dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment - --- | Parses a flag assignment. -parsecFlagAssignment :: CabalParsing m => m FlagAssignment -parsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Parse a non-empty flag assignment --- --- The flags have to explicitly start with minus or plus. --- --- @since 3.4.0.0 -parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment -parsecFlagAssignmentNonEmpty = mkFlagAssignment . toList <$> - P.sepByNonEmpty (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.char '+' - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) - --- | Show flag assignment. --- --- @since 3.4.0.0 -showFlagAssignment :: FlagAssignment -> String -showFlagAssignment = prettyShow . dispFlagAssignment - -------------------------------------------------------------------------------- --- Legacy: without requiring + -------------------------------------------------------------------------------- - --- | We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyShowFlagAssignment :: FlagAssignment -> String -legacyShowFlagAssignment = - prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment' - --- | @since 3.4.0.0 -legacyShowFlagAssignment' :: FlagAssignment -> [String] -legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment - --- | @since 3.4.0.0 -legacyShowFlagValue :: (FlagName, Bool) -> String -legacyShowFlagValue (f, True) = unFlagName f -legacyShowFlagValue (f, False) = '-' : unFlagName f - --- | --- We need this as far as we support custom setups older than 2.2.0.0 --- --- @since 3.4.0.0 -legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment -legacyParsecFlagAssignment = mkFlagAssignment <$> - P.sepBy (onFlag <|> offFlag) P.skipSpaces1 - where - onFlag = do - _ <- P.optional (P.char '+') - f <- parsec - return (f, True) - offFlag = do - _ <- P.char '-' - f <- parsec - return (f, False) diff --git a/src/Distribution/Types/ForeignLib.hs b/src/Distribution/Types/ForeignLib.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLib.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ForeignLib( - ForeignLib(..), - emptyForeignLib, - foreignLibModules, - foreignLibIsShared, - foreignLibVersion, - - LibVersionInfo, - mkLibVersionInfo, - libVersionInfoCRA, - libVersionNumber, - libVersionNumberShow, - libVersionMajor -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.System -import Distribution.Types.BuildInfo -import Distribution.Types.ForeignLibOption -import Distribution.Types.ForeignLibType -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A foreign library stanza is like a library stanza, except that --- the built code is intended for consumption by a non-Haskell client. -data ForeignLib = ForeignLib { - -- | Name of the foreign library - foreignLibName :: UnqualComponentName - -- | What kind of foreign library is this (static or dynamic). - , foreignLibType :: ForeignLibType - -- | What options apply to this foreign library (e.g., are we - -- merging in all foreign dependencies.) - , foreignLibOptions :: [ForeignLibOption] - -- | Build information for this foreign library. - , foreignLibBuildInfo :: BuildInfo - -- | Libtool-style version-info data to compute library version. - -- Refer to the libtool documentation on the - -- current:revision:age versioning scheme. - , foreignLibVersionInfo :: Maybe LibVersionInfo - -- | Linux library version - , foreignLibVersionLinux :: Maybe Version - - -- | (Windows-specific) module definition files - -- - -- This is a list rather than a maybe field so that we can flatten - -- the condition trees (for instance, when creating an sdist) - , foreignLibModDefFile :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable) - -instance Ord LibVersionInfo where - LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ = - case c `compare` c' of - EQ -> r `compare` r' - e -> e - -instance Show LibVersionInfo where - showsPrec d (LibVersionInfo c r a) = showParen (d > 10) - $ showString "mkLibVersionInfo " - . showsPrec 11 (c,r,a) - -instance Read LibVersionInfo where - readPrec = Read.parens $ do - Read.Ident "mkLibVersionInfo" <- Read.lexP - t <- Read.step Read.readPrec - return (mkLibVersionInfo t) - -instance Binary LibVersionInfo -instance Structured LibVersionInfo -instance NFData LibVersionInfo where rnf = genericRnf - -instance Pretty LibVersionInfo where - pretty (LibVersionInfo c r a) - = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a] - -instance Parsec LibVersionInfo where - parsec = do - c <- P.integral - (r, a) <- P.option (0,0) $ do - _ <- P.char ':' - r <- P.integral - a <- P.option 0 $ do - _ <- P.char ':' - P.integral - return (r,a) - return $ mkLibVersionInfo (c,r,a) - --- | Construct 'LibVersionInfo' from @(current, revision, age)@ --- numbers. --- --- For instance, @mkLibVersionInfo (3,0,0)@ constructs a --- 'LibVersionInfo' representing the version-info @3:0:0@. --- --- All version components must be non-negative. -mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo -mkLibVersionInfo (c,r,a) = LibVersionInfo c r a - --- | From a given 'LibVersionInfo', extract the @(current, revision, --- age)@ numbers. -libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int) -libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a) - --- | Given a version-info field, produce a @major.minor.build@ version -libVersionNumber :: LibVersionInfo -> (Int, Int, Int) -libVersionNumber (LibVersionInfo c r a) = (c-a , a , r) - --- | Given a version-info field, return @"major.minor.build"@ as a --- 'String' -libVersionNumberShow :: LibVersionInfo -> String -libVersionNumberShow v = - let (major, minor, build) = libVersionNumber v - in show major ++ "." ++ show minor ++ "." ++ show build - --- | Return the @major@ version of a version-info field. -libVersionMajor :: LibVersionInfo -> Int -libVersionMajor (LibVersionInfo c _ a) = c-a - -instance L.HasBuildInfo ForeignLib where - buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) - -instance Binary ForeignLib -instance Structured ForeignLib -instance NFData ForeignLib where rnf = genericRnf - -instance Semigroup ForeignLib where - a <> b = ForeignLib { - foreignLibName = combine' foreignLibName - , foreignLibType = combine foreignLibType - , foreignLibOptions = combine foreignLibOptions - , foreignLibBuildInfo = combine foreignLibBuildInfo - , foreignLibVersionInfo = combine'' foreignLibVersionInfo - , foreignLibVersionLinux = combine'' foreignLibVersionLinux - , foreignLibModDefFile = combine foreignLibModDefFile - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for executable field: '" - ++ x ++ "' and '" ++ y ++ "'" - combine'' field = field b - -instance Monoid ForeignLib where - mempty = ForeignLib { - foreignLibName = mempty - , foreignLibType = ForeignLibTypeUnknown - , foreignLibOptions = [] - , foreignLibBuildInfo = mempty - , foreignLibVersionInfo = Nothing - , foreignLibVersionLinux = Nothing - , foreignLibModDefFile = [] - } - mappend = (<>) - --- | An empty foreign library. -emptyForeignLib :: ForeignLib -emptyForeignLib = mempty - --- | Modules defined by a foreign library. -foreignLibModules :: ForeignLib -> [ModuleName] -foreignLibModules = otherModules . foreignLibBuildInfo - --- | Is the foreign library shared? -foreignLibIsShared :: ForeignLib -> Bool -foreignLibIsShared = foreignLibTypeIsShared . foreignLibType - --- | Get a version number for a foreign library. --- If we're on Linux, and a Linux version is specified, use that. --- If we're on Linux, and libtool-style version-info is specified, translate --- that field into appropriate version numbers. --- Otherwise, this feature is unsupported so we don't return any version data. -foreignLibVersion :: ForeignLib -> OS -> [Int] -foreignLibVersion flib Linux = - case foreignLibVersionLinux flib of - Just v -> versionNumbers v - Nothing -> - case foreignLibVersionInfo flib of - Just v' -> - let (major, minor, build) = libVersionNumber v' - in [major, minor, build] - Nothing -> [] -foreignLibVersion _ _ = [] diff --git a/src/Distribution/Types/ForeignLib/Lens.hs b/src/Distribution/Types/ForeignLib/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLib/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.ForeignLib.Lens ( - ForeignLib, - module Distribution.Types.ForeignLib.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) -import Distribution.Types.ForeignLibOption (ForeignLibOption) -import Distribution.Types.ForeignLibType (ForeignLibType) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.Version (Version) - -import qualified Distribution.Types.ForeignLib as T - -foreignLibName :: Lens' ForeignLib UnqualComponentName -foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) -{-# INLINE foreignLibName #-} - -foreignLibType :: Lens' ForeignLib ForeignLibType -foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) -{-# INLINE foreignLibType #-} - -foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] -foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s)) -{-# INLINE foreignLibOptions #-} - -foreignLibBuildInfo :: Lens' ForeignLib BuildInfo -foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s)) -{-# INLINE foreignLibBuildInfo #-} - -foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) -foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s)) -{-# INLINE foreignLibVersionInfo #-} - -foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) -foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s)) -{-# INLINE foreignLibVersionLinux #-} - -foreignLibModDefFile :: Lens' ForeignLib [FilePath] -foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s)) -{-# INLINE foreignLibModDefFile #-} diff --git a/src/Distribution/Types/ForeignLibOption.hs b/src/Distribution/Types/ForeignLibOption.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLibOption.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibOption( - ForeignLibOption(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data ForeignLibOption = - -- | Merge in all dependent libraries (i.e., use - -- @ghc -shared -static@ rather than just record - -- the dependencies, ala @ghc -shared -dynamic@). - -- This option is compulsory on Windows and unsupported - -- on other platforms. - ForeignLibStandalone - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibOption where - pretty ForeignLibStandalone = Disp.text "standalone" - -instance Parsec ForeignLibOption where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - case name of - "standalone" -> return ForeignLibStandalone - _ -> fail "unrecognized foreign-library option" - -instance Binary ForeignLibOption -instance Structured ForeignLibOption -instance NFData ForeignLibOption where rnf = genericRnf diff --git a/src/Distribution/Types/ForeignLibType.hs b/src/Distribution/Types/ForeignLibType.hs deleted file mode 100644 --- a/src/Distribution/Types/ForeignLibType.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.ForeignLibType( - ForeignLibType(..), - knownForeignLibTypes, - foreignLibTypeIsShared, -) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.PackageDescription.Utils - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | What kind of foreign library is to be built? -data ForeignLibType = - -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or - -- @.dll@ on Windows). - ForeignLibNativeShared - -- | A native static library (not currently supported.) - | ForeignLibNativeStatic - -- TODO: Maybe this should record a string? - | ForeignLibTypeUnknown - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty ForeignLibType where - pretty ForeignLibNativeShared = Disp.text "native-shared" - pretty ForeignLibNativeStatic = Disp.text "native-static" - pretty ForeignLibTypeUnknown = Disp.text "unknown" - -instance Parsec ForeignLibType where - parsec = do - name <- P.munch1 (\c -> isAlphaNum c || c == '-') - return $ case name of - "native-shared" -> ForeignLibNativeShared - "native-static" -> ForeignLibNativeStatic - _ -> ForeignLibTypeUnknown - -instance Binary ForeignLibType -instance Structured ForeignLibType -instance NFData ForeignLibType where rnf = genericRnf - -instance Semigroup ForeignLibType where - ForeignLibTypeUnknown <> b = b - a <> ForeignLibTypeUnknown = a - _ <> _ = error "Ambiguous foreign library type" - -instance Monoid ForeignLibType where - mempty = ForeignLibTypeUnknown - mappend = (<>) - -knownForeignLibTypes :: [ForeignLibType] -knownForeignLibTypes = [ - ForeignLibNativeShared - , ForeignLibNativeStatic - ] - -foreignLibTypeIsShared :: ForeignLibType -> Bool -foreignLibTypeIsShared t = - case t of - ForeignLibNativeShared -> True - ForeignLibNativeStatic -> False - ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type" diff --git a/src/Distribution/Types/GenericPackageDescription.hs b/src/Distribution/Types/GenericPackageDescription.hs deleted file mode 100644 --- a/src/Distribution/Types/GenericPackageDescription.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Distribution.Types.GenericPackageDescription ( - GenericPackageDescription(..), - emptyGenericPackageDescription, -) where - -import Prelude () -import Distribution.Compat.Prelude - --- lens -import Distribution.Compat.Lens as L -import qualified Distribution.Types.BuildInfo.Lens as L - -import Distribution.Types.PackageDescription - -import Distribution.Types.Benchmark -import Distribution.Types.CondTree -import Distribution.Types.ConfVar -import Distribution.Types.Dependency -import Distribution.Types.Executable -import Distribution.Types.Flag -import Distribution.Types.ForeignLib -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.UnqualComponentName -import Distribution.Package -import Distribution.Version - --- --------------------------------------------------------------------------- --- The 'GenericPackageDescription' type - -data GenericPackageDescription = - GenericPackageDescription - { packageDescription :: PackageDescription - , gpdScannedVersion :: Maybe Version - -- ^ This is a version as specified in source. - -- We populate this field in index reading for dummy GPDs, - -- only when GPD reading failed, but scanning haven't. - -- - -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion. - -- - -- Perfectly, PackageIndex should have sum type, so we don't need to - -- have dummy GPDs. - , genPackageFlags :: [PackageFlag] - , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library) - , condSubLibraries :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Library )] - , condForeignLibs :: [( UnqualComponentName - , CondTree ConfVar [Dependency] ForeignLib )] - , condExecutables :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Executable )] - , condTestSuites :: [( UnqualComponentName - , CondTree ConfVar [Dependency] TestSuite )] - , condBenchmarks :: [( UnqualComponentName - , CondTree ConfVar [Dependency] Benchmark )] - } - deriving (Show, Eq, Typeable, Data, Generic) - -instance Package GenericPackageDescription where - packageId = packageId . packageDescription - -instance Binary GenericPackageDescription -instance Structured GenericPackageDescription -instance NFData GenericPackageDescription where rnf = genericRnf - -emptyGenericPackageDescription :: GenericPackageDescription -emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos GenericPackageDescription where - traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> L.traverseBuildInfos f p - <*> pure v - <*> pure a1 - <*> (traverse . traverseCondTreeBuildInfo) f x1 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5 - <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6 - where - --- We use this traversal to keep [Dependency] field in CondTree up to date. -traverseCondTreeBuildInfo - :: forall f comp v. (Applicative f, L.HasBuildInfo comp) - => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo -traverseCondTreeBuildInfo g = node where - mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp - mkCondNode comp branches = CondNode comp (view L.targetBuildDepends comp) branches - - node (CondNode comp _ branches) = mkCondNode - <$> L.buildInfo g comp - <*> traverse branch branches - - branch (CondBranch v x y) = CondBranch v - <$> node x - <*> traverse node y diff --git a/src/Distribution/Types/GenericPackageDescription/Lens.hs b/src/Distribution/Types/GenericPackageDescription/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -module Distribution.Types.GenericPackageDescription.Lens ( - GenericPackageDescription, - PackageFlag, - FlagName, - ConfVar (..), - module Distribution.Types.GenericPackageDescription.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import qualified Distribution.Types.GenericPackageDescription as T - --- We import types from their packages, so we can remove unused imports --- and have wider inter-module dependency graph -import Distribution.Types.CondTree (CondTree) -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.Executable (Executable) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.Benchmark (Benchmark) -import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) ) -import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName) -import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Types.Library (Library) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.UnqualComponentName (UnqualComponentName) -import Distribution.System (Arch, OS) -import Distribution.Compiler (CompilerFlavor) -import Distribution.Version (Version, VersionRange) - -------------------------------------------------------------------------------- --- GenericPackageDescription -------------------------------------------------------------------------------- - -packageDescription :: Lens' GenericPackageDescription PackageDescription -packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) -{-# INLINE packageDescription #-} - -gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) -gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s)) -{-# INLINE gpdScannedVersion #-} - -genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] -genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) -{-# INLINE genPackageFlags #-} - -condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library)) -condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) -{-# INLINE condLibrary #-} - -condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] -condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) -{-# INLINE condSubLibraries #-} - -condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] -condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) -{-# INLINE condForeignLibs #-} - -condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] -condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) -{-# INLINE condExecutables #-} - -condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] -condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) -{-# INLINE condTestSuites #-} - -condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))] -condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s)) -{-# INLINE condBenchmarks #-} - -allCondTrees - :: Applicative f - => (forall a. CondTree ConfVar [Dependency] a - -> f (CondTree ConfVar [Dependency] a)) - -> GenericPackageDescription - -> f GenericPackageDescription -allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = - GenericPackageDescription - <$> pure p - <*> pure v - <*> pure a1 - <*> traverse f x1 - <*> (traverse . _2) f x2 - <*> (traverse . _2) f x3 - <*> (traverse . _2) f x4 - <*> (traverse . _2) f x5 - <*> (traverse . _2) f x6 - - -------------------------------------------------------------------------------- --- Flag -------------------------------------------------------------------------------- - -flagName :: Lens' PackageFlag FlagName -flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1) -{-# INLINE flagName #-} - -flagDescription :: Lens' PackageFlag String -flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2) -{-# INLINE flagDescription #-} - -flagDefault :: Lens' PackageFlag Bool -flagDefault f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 y1 x4) (f x3) -{-# INLINE flagDefault #-} - -flagManual :: Lens' PackageFlag Bool -flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y1) (f x4) -{-# INLINE flagManual #-} - -------------------------------------------------------------------------------- --- ConfVar -------------------------------------------------------------------------------- - -_OS :: Traversal' ConfVar OS -_OS f (OS os) = OS <$> f os -_OS _ x = pure x - -_Arch :: Traversal' ConfVar Arch -_Arch f (Arch arch) = Arch <$> f arch -_Arch _ x = pure x - -_PackageFlag :: Traversal' ConfVar FlagName -_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag -_PackageFlag _ x = pure x - -_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) -_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) -_Impl _ x = pure x diff --git a/src/Distribution/Types/GivenComponent.hs b/src/Distribution/Types/GivenComponent.hs --- a/src/Distribution/Types/GivenComponent.hs +++ b/src/Distribution/Types/GivenComponent.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.GivenComponent ( - GivenComponent(..) -) where +module Distribution.Types.GivenComponent + ( GivenComponent (..) + , PromisedComponent (..) + ) where + import Distribution.Compat.Prelude import Distribution.Types.ComponentId import Distribution.Types.LibraryName +import Distribution.Types.PackageId import Distribution.Types.PackageName -- | A 'GivenComponent' represents a library depended on and explicitly @@ -16,13 +18,30 @@ -- It enables Cabal to know which 'ComponentId' to associate with a library -- -- @since 2.3.0.0 -data GivenComponent = - GivenComponent - { givenComponentPackage :: PackageName - , givenComponentName :: LibraryName -- --dependency is for libraries - -- only, not for any component - , givenComponentId :: ComponentId } - deriving (Generic, Read, Show, Eq, Typeable) +data GivenComponent = GivenComponent + { givenComponentPackage :: PackageName + , givenComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , givenComponentId :: ComponentId + } + deriving (Generic, Read, Show, Eq) instance Binary GivenComponent instance Structured GivenComponent + +-- | A 'PromisedComponent' represents a promised library depended on and explicitly +-- specified by the user/client with @--promised-dependency@ +-- +-- It enables Cabal to know which 'ComponentId' to associate with a library +-- +-- @since 3.14.0.0 +data PromisedComponent = PromisedComponent + { promisedComponentPackage :: PackageId + , promisedComponentName :: LibraryName -- --dependency is for libraries + -- only, not for any component + , promisedComponentId :: ComponentId + } + deriving (Generic, Read, Show, Eq) + +instance Binary PromisedComponent +instance Structured PromisedComponent diff --git a/src/Distribution/Types/HookedBuildInfo.hs b/src/Distribution/Types/HookedBuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/HookedBuildInfo.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.HookedBuildInfo ( - HookedBuildInfo, - emptyHookedBuildInfo, - ) where - --- import Distribution.Compat.Prelude -import Distribution.Types.BuildInfo -import Distribution.Types.UnqualComponentName - --- | 'HookedBuildInfo' is mechanism that hooks can use to --- override the 'BuildInfo's inside packages. One example --- use-case (which is used in core libraries today) is as --- a way of passing flags which are computed by a configure --- script into Cabal. In this case, the autoconf build type adds --- hooks to read in a textual 'HookedBuildInfo' format prior --- to doing any operations. --- --- Quite honestly, this mechanism is a massive hack since we shouldn't --- be editing the 'PackageDescription' data structure (it's easy --- to assume that this data structure shouldn't change and --- run into bugs, see for example 1c20a6328579af9e37677d507e2e9836ef70ab9d). --- But it's a bit convenient, because there isn't another data --- structure that allows adding extra 'BuildInfo' style things. --- --- In any case, a lot of care has to be taken to make sure the --- 'HookedBuildInfo' is applied to the 'PackageDescription'. In --- general this process occurs in "Distribution.Simple", which is --- responsible for orchestrating the hooks mechanism. The --- general strategy: --- --- 1. We run the pre-hook, which produces a 'HookedBuildInfo' --- (e.g., in the Autoconf case, it reads it out from a file). --- 2. We sanity-check the hooked build info with --- 'sanityCheckHookedBuildInfo'. --- 3. We update our 'PackageDescription' (either freshly read --- or cached from 'LocalBuildInfo') with 'updatePackageDescription'. --- --- In principle, we are also supposed to update the copy of --- the 'PackageDescription' stored in 'LocalBuildInfo' --- at 'localPkgDescr'. Unfortunately, in practice, there --- are lots of Custom setup scripts which fail to update --- 'localPkgDescr' so you really shouldn't rely on it. --- It's not DEPRECATED because there are legitimate uses --- for it, but... yeah. Sharp knife. See --- --- for more information on the issue. --- --- It is not well-specified whether or not a 'HookedBuildInfo' applied --- at configure time is persistent to the 'LocalBuildInfo'. The --- fact that 'HookedBuildInfo' is passed to 'confHook' MIGHT SUGGEST --- that the 'HookedBuildInfo' is applied at this time, but actually --- since 9317b67e6122ab14e53f81b573bd0ecb388eca5a it has been ONLY used --- to create a modified package description that we check for problems: --- it is never actually saved to the LBI. Since 'HookedBuildInfo' is --- applied monoidally to the existing build infos (and it is not an --- idempotent monoid), it could break things to save it, since we --- are obligated to apply any new 'HookedBuildInfo' and then we'd --- get the effect twice. But this does mean we have to re-apply --- it every time. Hey, it's more flexibility. -type HookedBuildInfo = (Maybe BuildInfo, [(UnqualComponentName, BuildInfo)]) - -emptyHookedBuildInfo :: HookedBuildInfo -emptyHookedBuildInfo = (Nothing, []) diff --git a/src/Distribution/Types/IncludeRenaming.hs b/src/Distribution/Types/IncludeRenaming.hs deleted file mode 100644 --- a/src/Distribution/Types/IncludeRenaming.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.IncludeRenaming ( - IncludeRenaming(..), - defaultIncludeRenaming, - isDefaultIncludeRenaming, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.ModuleRenaming - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (text) -import qualified Text.PrettyPrint as Disp - --- --------------------------------------------------------------------------- --- Module renaming - --- | A renaming on an include: (provides renaming, requires renaming) -data IncludeRenaming - = IncludeRenaming { - includeProvidesRn :: ModuleRenaming, - includeRequiresRn :: ModuleRenaming - } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary IncludeRenaming -instance Structured IncludeRenaming - -instance NFData IncludeRenaming where rnf = genericRnf - --- | The 'defaultIncludeRenaming' applied when you only @build-depends@ --- on a package. -defaultIncludeRenaming :: IncludeRenaming -defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming - --- | Is an 'IncludeRenaming' the default one? -isDefaultIncludeRenaming :: IncludeRenaming -> Bool -isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r - -instance Pretty IncludeRenaming where - pretty (IncludeRenaming prov_rn req_rn) = - pretty prov_rn - <+> (if isDefaultRenaming req_rn - then Disp.empty - else text "requires" <+> pretty req_rn) - -instance Parsec IncludeRenaming where - parsec = do - prov_rn <- parsec - req_rn <- P.option defaultRenaming $ P.try $ do - P.spaces -- no need to be space - _ <- P.string "requires" - P.spaces - parsec - -- Requirements don't really care if they're mentioned - -- or not (since you can't thin a requirement.) But - -- we have a little hack in Configure to combine - -- the provisions and requirements together before passing - -- them to GHC, and so the most neutral choice for a requirement - -- is for the "with" field to be False, so we correctly - -- thin provisions. - return (IncludeRenaming prov_rn req_rn) diff --git a/src/Distribution/Types/InstalledPackageInfo.hs b/src/Distribution/Types/InstalledPackageInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -module Distribution.Types.InstalledPackageInfo ( - InstalledPackageInfo (..), - emptyInstalledPackageInfo, - mungedPackageId, - mungedPackageName, - AbiDependency (..), - ExposedModule (..), - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.Compat.Graph (IsNode (..)) -import Distribution.License -import Distribution.ModuleName -import Distribution.Package hiding (installedUnitId) -import Distribution.Types.AbiDependency -import Distribution.Types.ExposedModule -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageId -import Distribution.Types.MungedPackageName -import Distribution.Version (nullVersion) -import Distribution.Utils.ShortText (ShortText) - -import qualified Distribution.Package as Package -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The InstalledPackageInfo type - --- For BC reasons, we continue to name this record an InstalledPackageInfo; --- but it would more accurately be called an InstalledUnitInfo with Backpack -data InstalledPackageInfo - = InstalledPackageInfo { - -- these parts (sourcePackageId, installedUnitId) are - -- exactly the same as PackageDescription - sourcePackageId :: PackageId, - sourceLibName :: LibraryName, - installedComponentId_ :: ComponentId, - libVisibility :: LibraryVisibility, - installedUnitId :: UnitId, - -- INVARIANT: if this package is definite, OpenModule's - -- OpenUnitId directly records UnitId. If it is - -- indefinite, OpenModule is always an OpenModuleVar - -- with the same ModuleName as the key. - instantiatedWith :: [(ModuleName, OpenModule)], - compatPackageKey :: String, - license :: Either SPDX.License License, - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - homepage :: !ShortText, - pkgUrl :: !ShortText, - synopsis :: !ShortText, - description :: !ShortText, - category :: !ShortText, - -- these parts are required by an installed package only: - abiHash :: AbiHash, - indefinite :: Bool, - exposed :: Bool, - -- INVARIANT: if the package is definite, OpenModule's - -- OpenUnitId directly records UnitId. - exposedModules :: [ExposedModule], - hiddenModules :: [ModuleName], - trusted :: Bool, - importDirs :: [FilePath], - libraryDirs :: [FilePath], - libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs' - dataDir :: FilePath, - hsLibraries :: [String], - extraLibraries :: [String], - extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi - includeDirs :: [FilePath], - includes :: [String], - -- INVARIANT: if the package is definite, UnitId is NOT - -- a ComponentId of an indefinite package - depends :: [UnitId], - abiDepends :: [AbiDependency], - ccOptions :: [String], - cxxOptions :: [String], - ldOptions :: [String], - frameworkDirs :: [FilePath], - frameworks :: [String], - haddockInterfaces :: [FilePath], - haddockHTMLs :: [FilePath], - pkgRoot :: Maybe FilePath - } - deriving (Eq, Generic, Typeable, Read, Show) - -instance Binary InstalledPackageInfo -instance Structured InstalledPackageInfo - -instance NFData InstalledPackageInfo where rnf = genericRnf - -instance Package.HasMungedPackageId InstalledPackageInfo where - mungedId = mungedPackageId - -instance Package.Package InstalledPackageInfo where - packageId = sourcePackageId - -instance Package.HasUnitId InstalledPackageInfo where - installedUnitId = installedUnitId - -instance Package.PackageInstalled InstalledPackageInfo where - installedDepends = depends - -instance IsNode InstalledPackageInfo where - type Key InstalledPackageInfo = UnitId - nodeKey = installedUnitId - nodeNeighbors = depends - -mungedPackageId :: InstalledPackageInfo -> MungedPackageId -mungedPackageId ipi = - MungedPackageId (mungedPackageName ipi) (packageVersion ipi) - --- | Returns the munged package name, which we write into @name@ for --- compatibility with old versions of GHC. -mungedPackageName :: InstalledPackageInfo -> MungedPackageName -mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi) - -emptyInstalledPackageInfo :: InstalledPackageInfo -emptyInstalledPackageInfo - = InstalledPackageInfo { - sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion, - sourceLibName = LMainLibName, - installedComponentId_ = mkComponentId "", - installedUnitId = mkUnitId "", - instantiatedWith = [], - compatPackageKey = "", - license = Left SPDX.NONE, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - synopsis = "", - description = "", - category = "", - abiHash = mkAbiHash "", - indefinite = False, - exposed = False, - exposedModules = [], - hiddenModules = [], - trusted = False, - importDirs = [], - libraryDirs = [], - libraryDynDirs = [], - dataDir = "", - hsLibraries = [], - extraLibraries = [], - extraGHCiLibraries= [], - includeDirs = [], - includes = [], - depends = [], - abiDepends = [], - ccOptions = [], - cxxOptions = [], - ldOptions = [], - frameworkDirs = [], - frameworks = [], - haddockInterfaces = [], - haddockHTMLs = [], - pkgRoot = Nothing, - libVisibility = LibraryVisibilityPrivate - } diff --git a/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Distribution.Types.InstalledPackageInfo.FieldGrammar ( - ipiFieldGrammar, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack -import Distribution.CabalSpecVersion -import Distribution.Compat.Lens (Lens', (&), (.~)) -import Distribution.Compat.Newtype -import Distribution.FieldGrammar -import Distribution.FieldGrammar.FieldDescrs -import Distribution.License -import Distribution.ModuleName -import Distribution.Package -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.LibraryVisibility -import Distribution.Types.MungedPackageName -import Distribution.Types.UnqualComponentName -import Distribution.Version - -import qualified Data.Char as Char -import qualified Data.Map as Map -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.SPDX as SPDX -import qualified Text.PrettyPrint as Disp - -import Distribution.Types.InstalledPackageInfo - -import qualified Distribution.Types.InstalledPackageInfo.Lens as L -import qualified Distribution.Types.PackageId.Lens as L - --- Note: GHC goes nuts and inlines everything, --- One can see e.g. in -ddump-simpl-stats: --- --- 34886 KnownBranch --- 8197 wild1_ixF0 --- --- https://gitlab.haskell.org/ghc/ghc/-/issues/13253 might be the cause. --- --- The workaround is to prevent GHC optimising the code: -infixl 4 <@> -(<@>) :: Applicative f => f (a -> b) -> f a -> f b -f <@> x = f <*> x -{-# NOINLINE (<@>) #-} - -ipiFieldGrammar - :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic) - , c (Identity AbiHash) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnitId) - , c (Identity UnqualComponentName) - , c (List FSep (Identity AbiDependency) AbiDependency) - , c (List FSep (Identity UnitId) UnitId) - , c (List FSep (MQuoted ModuleName) ModuleName) - , c (List FSep FilePathNT String) - , c (List FSep Token String) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - , c CompatPackageKey - , c ExposedModules - , c InstWith - , c SpecLicenseLenient - ) - => g InstalledPackageInfo InstalledPackageInfo -ipiFieldGrammar = mkInstalledPackageInfo - -- Deprecated fields - <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList - --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b - ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore" - -- Very basic fields: name, version, package-name, lib-name and visibility - <@> blurFieldGrammar basic basicFieldGrammar - -- Basic fields - <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "") - <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith [] - <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey "" - <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE) - <@> freeTextFieldDefST "copyright" L.copyright - <@> freeTextFieldDefST "maintainer" L.maintainer - <@> freeTextFieldDefST "author" L.author - <@> freeTextFieldDefST "stability" L.stability - <@> freeTextFieldDefST "homepage" L.homepage - <@> freeTextFieldDefST "package-url" L.pkgUrl - <@> freeTextFieldDefST "synopsis" L.synopsis - <@> freeTextFieldDefST "description" L.description - <@> freeTextFieldDefST "category" L.category - -- Installed fields - <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "") - <@> booleanFieldDef "indefinite" L.indefinite False - <@> booleanFieldDef "exposed" L.exposed False - <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules - <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules - <@> booleanFieldDef "trusted" L.trusted False - <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs - <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs - <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs - <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir "" - <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries - <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries - <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries - <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs - <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes - <@> monoidalFieldAla "depends" (alaList FSep) L.depends - <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends - <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions - <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions - <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions - <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs - <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks - <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces - <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs - <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot - where - mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo - -- _basicPkgName is not used - -- setMaybePackageId says it can be no-op. - (PackageIdentifier pn _basicVersion) - (combineLibraryName ln _basicLibName) - (mkComponentId "") -- installedComponentId_, not in use - _basicLibVisibility - where - MungedPackageName pn ln = _basicName -{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} - --- (forall b. [b]) ~ () -unitedList :: Lens' a [b] -unitedList f s = s <$ f [] - -------------------------------------------------------------------------------- --- Helper functions -------------------------------------------------------------------------------- - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l - --- To maintain backwards-compatibility, we accept both comma/non-comma --- separated variants of this field. You SHOULD use the comma syntax if you --- use any new functions, although actually it's unambiguous due to a quirk --- of the fact that modules must start with capital letters. - -showExposedModules :: [ExposedModule] -> Disp.Doc -showExposedModules xs - | all isExposedModule xs = Disp.fsep (map pretty xs) - | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs)) - where isExposedModule (ExposedModule _ Nothing) = True - isExposedModule _ = False - --- | Setter for the @package-name@ field. It should be acceptable for this --- to be a no-op. -setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMaybePackageName Nothing ipi = ipi -setMaybePackageName (Just pn) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - } - -setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo -setMungedPackageName (MungedPackageName pn ln) ipi = ipi - { sourcePackageId = (sourcePackageId ipi) {pkgName=pn} - , sourceLibName = ln - } - ---- | Returns @Just@ if the @name@ field of the IPI record would not contain ---- the package name verbatim. This helps us avoid writing @package-name@ ---- when it's redundant. -maybePackageName :: InstalledPackageInfo -> Maybe PackageName -maybePackageName ipi = case sourceLibName ipi of - LMainLibName -> Nothing - LSubLibName _ -> Just (packageName ipi) - -------------------------------------------------------------------------------- --- Auxiliary types -------------------------------------------------------------------------------- - -newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] } - -instance Newtype [ExposedModule] ExposedModules - -instance Parsec ExposedModules where - parsec = ExposedModules <$> parsecOptCommaList parsec - -instance Pretty ExposedModules where - pretty = showExposedModules . getExposedModules - -newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String } - -instance Newtype String CompatPackageKey - -instance Pretty CompatPackageKey where - pretty = Disp.text . getCompatPackageKey - -instance Parsec CompatPackageKey where - parsec = CompatPackageKey <$> P.munch1 uid_char where - uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String) - -newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] } - -instance Newtype [(ModuleName, OpenModule)] InstWith - -instance Pretty InstWith where - pretty = dispOpenModuleSubst . Map.fromList . getInstWith - -instance Parsec InstWith where - parsec = InstWith . Map.toList <$> parsecOpenModuleSubst - --- | SPDX License expression or legacy license. Lenient parser, accepts either. -newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License } - -instance Newtype (Either SPDX.License License) SpecLicenseLenient - -instance Parsec SpecLicenseLenient where - parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec - -instance Pretty SpecLicenseLenient where - pretty = either pretty pretty . getSpecLicenseLenient - -------------------------------------------------------------------------------- --- Basic fields -------------------------------------------------------------------------------- - --- | This type is used to mangle fields as --- in serialised textual representation --- to the actual 'InstalledPackageInfo' fields. -data Basic = Basic - { _basicName :: MungedPackageName - , _basicVersion :: Version - , _basicPkgName :: Maybe PackageName - , _basicLibName :: LibraryName - , _basicLibVisibility :: LibraryVisibility - } - -basic :: Lens' InstalledPackageInfo Basic -basic f ipi = g <$> f b - where - b = Basic - (mungedPackageName ipi) - (packageVersion ipi) - (maybePackageName ipi) - (sourceLibName ipi) - (libVisibility ipi) - - g (Basic n v pn ln lv) = ipi - & setMungedPackageName n - & L.sourcePackageId . L.pkgVersion .~ v - & setMaybePackageName pn - & L.sourceLibName .~ ln - & L.libVisibility .~ lv - -basicName :: Lens' Basic MungedPackageName -basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b) -{-# INLINE basicName #-} - -basicVersion :: Lens' Basic Version -basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b) -{-# INLINE basicVersion #-} - -basicPkgName :: Lens' Basic (Maybe PackageName) -basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b) -{-# INLINE basicPkgName #-} - -basicLibName :: Lens' Basic (Maybe UnqualComponentName) -basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$> - f (libraryNameString (_basicLibName b)) -{-# INLINE basicLibName #-} - -basicLibVisibility :: Lens' Basic LibraryVisibility -basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$> - f (_basicLibVisibility b) -{-# INLINE basicLibVisibility #-} - -basicFieldGrammar - :: ( FieldGrammar c g, Applicative (g Basic) - , c (Identity LibraryVisibility) - , c (Identity PackageName) - , c (Identity UnqualComponentName) - , c (MQuoted MungedPackageName) - , c (MQuoted Version) - ) - => g Basic Basic -basicFieldGrammar = mkBasic - <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) - <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion - <*> optionalField "package-name" basicPkgName - <*> optionalField "lib-name" basicLibName - <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate - where - mkBasic n v pn ln lv = Basic n v pn ln' lv' - where - ln' = maybe LMainLibName LSubLibName ln - -- Older GHCs (<8.8) always report installed libraries as private - -- because their ghc-pkg builds with an older Cabal. - -- So we always set LibraryVisibilityPublic for main (unnamed) libs. - -- This can be removed once we stop supporting GHC<8.8, at the - -- condition that we keep marking main libraries as public when - -- registering them. - lv' = if - let MungedPackageName _ mln = n in - -- We need to check both because on ghc<8.2 ln' will always - -- be LMainLibName - ln' == LMainLibName && mln == LMainLibName - then LibraryVisibilityPublic - else lv diff --git a/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/src/Distribution/Types/InstalledPackageInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/InstalledPackageInfo/Lens.hs +++ /dev/null @@ -1,190 +0,0 @@ -module Distribution.Types.InstalledPackageInfo.Lens ( - InstalledPackageInfo, - module Distribution.Types.InstalledPackageInfo.Lens - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Backpack (OpenModule) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId) -import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Utils.ShortText (ShortText) - - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.InstalledPackageInfo as T - -sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier -sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s)) -{-# INLINE sourcePackageId #-} - -installedUnitId :: Lens' InstalledPackageInfo UnitId -installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s)) -{-# INLINE installedUnitId #-} - -installedComponentId_ :: Lens' InstalledPackageInfo ComponentId -installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s)) -{-# INLINE installedComponentId_ #-} - -instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)] -instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s)) -{-# INLINE instantiatedWith #-} - -sourceLibName :: Lens' InstalledPackageInfo LibraryName -sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s)) -{-# INLINE sourceLibName #-} - -compatPackageKey :: Lens' InstalledPackageInfo String -compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s)) -{-# INLINE compatPackageKey #-} - -license :: Lens' InstalledPackageInfo (Either SPDX.License License) -license f s = fmap (\x -> s { T.license = x }) (f (T.license s)) -{-# INLINE license #-} - -copyright :: Lens' InstalledPackageInfo ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' InstalledPackageInfo ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' InstalledPackageInfo ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' InstalledPackageInfo ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -homepage :: Lens' InstalledPackageInfo ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' InstalledPackageInfo ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -synopsis :: Lens' InstalledPackageInfo ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' InstalledPackageInfo ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' InstalledPackageInfo ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -abiHash :: Lens' InstalledPackageInfo AbiHash -abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s)) -{-# INLINE abiHash #-} - -indefinite :: Lens' InstalledPackageInfo Bool -indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s)) -{-# INLINE indefinite #-} - -exposed :: Lens' InstalledPackageInfo Bool -exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s)) -{-# INLINE exposed #-} - -exposedModules :: Lens' InstalledPackageInfo [ExposedModule] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -hiddenModules :: Lens' InstalledPackageInfo [ModuleName] -hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s)) -{-# INLINE hiddenModules #-} - -trusted :: Lens' InstalledPackageInfo Bool -trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s)) -{-# INLINE trusted #-} - -importDirs :: Lens' InstalledPackageInfo [FilePath] -importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s)) -{-# INLINE importDirs #-} - -libraryDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s)) -{-# INLINE libraryDirs #-} - -libraryDynDirs :: Lens' InstalledPackageInfo [FilePath] -libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s)) -{-# INLINE libraryDynDirs #-} - -dataDir :: Lens' InstalledPackageInfo FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -hsLibraries :: Lens' InstalledPackageInfo [String] -hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s)) -{-# INLINE hsLibraries #-} - -extraLibraries :: Lens' InstalledPackageInfo [String] -extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s)) -{-# INLINE extraLibraries #-} - -extraGHCiLibraries :: Lens' InstalledPackageInfo [String] -extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s)) -{-# INLINE extraGHCiLibraries #-} - -includeDirs :: Lens' InstalledPackageInfo [FilePath] -includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s)) -{-# INLINE includeDirs #-} - -includes :: Lens' InstalledPackageInfo [String] -includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s)) -{-# INLINE includes #-} - -depends :: Lens' InstalledPackageInfo [UnitId] -depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s)) -{-# INLINE depends #-} - -abiDepends :: Lens' InstalledPackageInfo [AbiDependency] -abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s)) -{-# INLINE abiDepends #-} - -ccOptions :: Lens' InstalledPackageInfo [String] -ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s)) -{-# INLINE ccOptions #-} - -cxxOptions :: Lens' InstalledPackageInfo [String] -cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s)) -{-# INLINE cxxOptions #-} - -ldOptions :: Lens' InstalledPackageInfo [String] -ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s)) -{-# INLINE ldOptions #-} - -frameworkDirs :: Lens' InstalledPackageInfo [FilePath] -frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s)) -{-# INLINE frameworkDirs #-} - -frameworks :: Lens' InstalledPackageInfo [String] -frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s)) -{-# INLINE frameworks #-} - -haddockInterfaces :: Lens' InstalledPackageInfo [FilePath] -haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s)) -{-# INLINE haddockInterfaces #-} - -haddockHTMLs :: Lens' InstalledPackageInfo [FilePath] -haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s)) -{-# INLINE haddockHTMLs #-} - -pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath) -pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s)) -{-# INLINE pkgRoot #-} - -libVisibility :: Lens' InstalledPackageInfo LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - diff --git a/src/Distribution/Types/LegacyExeDependency.hs b/src/Distribution/Types/LegacyExeDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/LegacyExeDependency.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.LegacyExeDependency - ( LegacyExeDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Version (VersionRange, anyVersion) - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Describes a legacy `build-tools`-style dependency on an executable --- --- It is "legacy" because we do not know what the build-tool referred to. It --- could refer to a pkg-config executable (PkgconfigName), or an internal --- executable (UnqualComponentName). Thus the name is stringly typed. --- --- @since 2.0.0.2 -data LegacyExeDependency = LegacyExeDependency - String - VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary LegacyExeDependency -instance Structured LegacyExeDependency -instance NFData LegacyExeDependency where rnf = genericRnf - -instance Pretty LegacyExeDependency where - pretty (LegacyExeDependency name ver) = - Disp.text name <+> pretty ver - -instance Parsec LegacyExeDependency where - parsec = do - name <- parsecMaybeQuoted nameP - P.spaces - verRange <- parsecMaybeQuoted parsec <|> pure anyVersion - pure $ LegacyExeDependency name verRange - where - nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-') - component = do - cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_') - if all isDigit cs then fail "invalid component" else return cs diff --git a/src/Distribution/Types/Lens.hs b/src/Distribution/Types/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Lens.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Distribution.Types.Lens ( - module Distribution.Types.Benchmark.Lens, - module Distribution.Types.BuildInfo.Lens, - module Distribution.Types.Executable.Lens, - module Distribution.Types.ForeignLib.Lens, - module Distribution.Types.GenericPackageDescription.Lens, - module Distribution.Types.Library.Lens, - module Distribution.Types.PackageDescription.Lens, - module Distribution.Types.PackageId.Lens, - module Distribution.Types.SetupBuildInfo.Lens, - module Distribution.Types.SourceRepo.Lens, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Types.Benchmark.Lens -import Distribution.Types.BuildInfo.Lens -import Distribution.Types.Executable.Lens -import Distribution.Types.ForeignLib.Lens -import Distribution.Types.GenericPackageDescription.Lens -import Distribution.Types.Library.Lens -import Distribution.Types.PackageDescription.Lens -import Distribution.Types.PackageId.Lens -import Distribution.Types.SetupBuildInfo.Lens -import Distribution.Types.SourceRepo.Lens -import Distribution.Types.TestSuite.Lens diff --git a/src/Distribution/Types/Library.hs b/src/Distribution/Types/Library.hs deleted file mode 100644 --- a/src/Distribution/Types/Library.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Library ( - Library(..), - emptyLibrary, - explicitLibModules, - libModulesAutogen, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Types.BuildInfo -import Distribution.Types.LibraryVisibility -import Distribution.Types.ModuleReexport -import Distribution.Types.LibraryName - -import qualified Distribution.Types.BuildInfo.Lens as L - -data Library = Library - { libName :: LibraryName - , exposedModules :: [ModuleName] - , reexportedModules :: [ModuleReexport] - , signatures :: [ModuleName] -- ^ What sigs need implementations? - , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) - , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be dependent from outside. - , libBuildInfo :: BuildInfo - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance L.HasBuildInfo Library where - buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) - -instance Binary Library -instance Structured Library -instance NFData Library where rnf = genericRnf - -emptyLibrary :: Library -emptyLibrary = Library - { libName = LMainLibName - , exposedModules = mempty - , reexportedModules = mempty - , signatures = mempty - , libExposed = True - , libVisibility = mempty - , libBuildInfo = mempty - } - --- | This instance is not good. --- --- We need it for 'PackageDescription.Configuration.addBuildableCondition'. --- More correct method would be some kind of "create empty clone". --- --- More concretely, 'addBuildableCondition' will make `libVisibility = False` --- libraries when `buildable: false`. This may cause problems. --- -instance Monoid Library where - mempty = emptyLibrary - mappend = (<>) - -instance Semigroup Library where - a <> b = Library - { libName = combineLibraryName (libName a) (libName b) - , exposedModules = combine exposedModules - , reexportedModules = combine reexportedModules - , signatures = combine signatures - , libExposed = libExposed a && libExposed b -- so False propagates - , libVisibility = combine libVisibility - , libBuildInfo = combine libBuildInfo - } - where combine field = field a `mappend` field b - --- | Get all the module names from the library (exposed and internal modules) --- which are explicitly listed in the package description which would --- need to be compiled. (This does not include reexports, which --- do not need to be compiled.) This may not include all modules for which --- GHC generated interface files (i.e., implicit modules.) -explicitLibModules :: Library -> [ModuleName] -explicitLibModules lib = exposedModules lib - ++ otherModules (libBuildInfo lib) - ++ signatures lib - --- | Get all the auto generated module names from the library, exposed or not. --- This are a subset of 'libModules'. -libModulesAutogen :: Library -> [ModuleName] -libModulesAutogen lib = autogenModules (libBuildInfo lib) - --- | Combine 'LibraryName'. in parsing we prefer value coming --- from munged @name@ field over the @lib-name@. --- --- /Should/ be irrelevant. -combineLibraryName :: LibraryName -> LibraryName -> LibraryName -combineLibraryName l@(LSubLibName _) _ = l -combineLibraryName _ l = l diff --git a/src/Distribution/Types/Library/Lens.hs b/src/Distribution/Types/Library/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/Library/Lens.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Distribution.Types.Library.Lens ( - Library, - module Distribution.Types.Library.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Library (Library) -import Distribution.Types.LibraryName (LibraryName) -import Distribution.Types.LibraryVisibility (LibraryVisibility) -import Distribution.Types.ModuleReexport (ModuleReexport) - -import qualified Distribution.Types.Library as T - -libName :: Lens' Library LibraryName -libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) -{-# INLINE libName #-} - -exposedModules :: Lens' Library [ModuleName] -exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) -{-# INLINE exposedModules #-} - -reexportedModules :: Lens' Library [ModuleReexport] -reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s)) -{-# INLINE reexportedModules #-} - -signatures :: Lens' Library [ModuleName] -signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s)) -{-# INLINE signatures #-} - -libExposed :: Lens' Library Bool -libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s)) -{-# INLINE libExposed #-} - -libVisibility :: Lens' Library LibraryVisibility -libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s)) -{-# INLINE libVisibility #-} - -libBuildInfo :: Lens' Library BuildInfo -libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s)) -{-# INLINE libBuildInfo #-} diff --git a/src/Distribution/Types/LibraryName.hs b/src/Distribution/Types/LibraryName.hs deleted file mode 100644 --- a/src/Distribution/Types/LibraryName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.LibraryName ( - LibraryName(..), - defaultLibName, - maybeToLibraryName, - showLibraryName, - libraryNameStanza, - libraryNameString, - -- * Pretty & Parse - prettyLibraryNameComponent, - parsecLibraryNameComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.UnqualComponentName -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - -data LibraryName = LMainLibName - | LSubLibName UnqualComponentName - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary LibraryName -instance Structured LibraryName -instance NFData LibraryName where rnf = genericRnf - --- | Pretty print 'LibraryName' in build-target-ish syntax. --- --- /Note:/ there are no 'Pretty' or 'Parsec' instances, --- as there's other way to represent 'LibraryName', namely as bare --- 'UnqualComponentName'. -prettyLibraryNameComponent :: LibraryName -> Disp.Doc -prettyLibraryNameComponent LMainLibName = Disp.text "lib" -prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str - -parsecLibraryNameComponent :: CabalParsing m => m LibraryName -parsecLibraryNameComponent = do - _ <- P.string "lib" - parseComposite <|> parseSingle - where - parseSingle = return LMainLibName - parseComposite = do - _ <- P.char ':' - LSubLibName <$> parsec - -defaultLibName :: LibraryName -defaultLibName = LMainLibName - -showLibraryName :: LibraryName -> String -showLibraryName LMainLibName = "library" -showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'" - -libraryNameStanza :: LibraryName -> String -libraryNameStanza LMainLibName = "library" -libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name - -libraryNameString :: LibraryName -> Maybe UnqualComponentName -libraryNameString LMainLibName = Nothing -libraryNameString (LSubLibName n) = Just n - --- | Convert the 'UnqualComponentName' of a library into a --- 'LibraryName'. -maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName -maybeToLibraryName Nothing = LMainLibName -maybeToLibraryName (Just n) = LSubLibName n - diff --git a/src/Distribution/Types/LibraryVisibility.hs b/src/Distribution/Types/LibraryVisibility.hs deleted file mode 100644 --- a/src/Distribution/Types/LibraryVisibility.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.LibraryVisibility( - LibraryVisibility(..), -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Multi-lib visibility --- --- @since 3.0.0.0 --- -data LibraryVisibility - -- | Can be depenendent from other packages - = LibraryVisibilityPublic - -- | Internal library, default - | LibraryVisibilityPrivate - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Pretty LibraryVisibility where - pretty LibraryVisibilityPublic = Disp.text "public" - pretty LibraryVisibilityPrivate = Disp.text "private" - -instance Parsec LibraryVisibility where - parsec = do - name <- P.munch1 isAlpha - parsecWarning PWTExperimental "visibility is experimental feature (issue #5660)" - case name of - "public" -> return LibraryVisibilityPublic - "private" -> return LibraryVisibilityPrivate - _ -> fail $ "Unknown visibility: " ++ name - -instance Binary LibraryVisibility -instance Structured LibraryVisibility -instance NFData LibraryVisibility where rnf = genericRnf - -instance Semigroup LibraryVisibility where - LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate - _ <> _ = LibraryVisibilityPublic - -instance Monoid LibraryVisibility where - mempty = LibraryVisibilityPrivate - mappend = (<>) diff --git a/src/Distribution/Types/LocalBuildConfig.hs b/src/Distribution/Types/LocalBuildConfig.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/LocalBuildConfig.hs @@ -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 + } diff --git a/src/Distribution/Types/LocalBuildInfo.hs b/src/Distribution/Types/LocalBuildInfo.hs --- a/src/Distribution/Types/LocalBuildInfo.hs +++ b/src/Distribution/Types/LocalBuildInfo.hs @@ -1,170 +1,322 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} -module Distribution.Types.LocalBuildInfo ( - -- * The type - - LocalBuildInfo(..), +module Distribution.Types.LocalBuildInfo + ( -- * The types + LocalBuildInfo + ( LocalBuildInfo + , configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withProfLibShared + , withDynExe + , withFullyStaticExe + , withProfExe + , withSharedLib + , withStaticLib + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + , .. + ) -- * Convenience accessors - - localComponentId, - localUnitId, - localCompatPackageKey, - localPackage, + , localComponentId + , localUnitId + , localCompatPackageKey + , localPackage + , buildDir + , buildDirPBD + , setupFlagsBuildDir + , distPrefLBI + , packageRoot + , progPrefix + , progSuffix -- * Build targets of the 'LocalBuildInfo'. - - componentNameCLBIs, - - -- NB: the primes mean that they take a 'PackageDescription' - -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. - -- More logical types would drop this argument, but - -- at the moment, this is the ONLY supported function, because - -- 'localPkgDescr' is not guaranteed to match. At some point - -- we will fix it and then we can use the (free) unprimed - -- namespace for the correct commands. - -- - -- See https://github.com/haskell/cabal/issues/3606 for more - -- details. + , componentNameCLBIs + -- NB: the primes mean that they take a 'PackageDescription' + -- which may not match 'localPkgDescr' in 'LocalBuildInfo'. + -- More logical types would drop this argument, but + -- at the moment, this is the ONLY supported function, because + -- 'localPkgDescr' is not guaranteed to match. At some point + -- we will fix it and then we can use the (free) unprimed + -- namespace for the correct commands. + -- + -- See https://github.com/haskell/cabal/issues/3606 for more + -- details. - componentNameTargets', - unitIdTarget', - allTargetsInBuildOrder', - withAllTargetsInBuildOrder', - neededTargetsInBuildOrder', - withNeededTargetsInBuildOrder', - testCoverage, + , componentNameTargets' + , unitIdTarget' + , allTargetsInBuildOrder' + , withAllTargetsInBuildOrder' + , neededTargetsInBuildOrder' + , withNeededTargetsInBuildOrder' + , testCoverage + , buildWays -- * Functions you SHOULD NOT USE (yet), but are defined here to - -- prevent someone from accidentally defining them - componentNameTargets, - unitIdTarget, - allTargetsInBuildOrder, - withAllTargetsInBuildOrder, - neededTargetsInBuildOrder, - withNeededTargetsInBuildOrder, + -- prevent someone from accidentally defining them + + , componentNameTargets + , unitIdTarget + , allTargetsInBuildOrder + , withAllTargetsInBuildOrder + , neededTargetsInBuildOrder + , withNeededTargetsInBuildOrder ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.PackageDescription +import Distribution.Types.ComponentId import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.ComponentId +import Distribution.Types.GivenComponent +import qualified Distribution.Types.LocalBuildConfig as LBC +import Distribution.Types.PackageDescription import Distribution.Types.PackageId -import Distribution.Types.UnitId import Distribution.Types.TargetInfo +import Distribution.Types.UnitId -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import Distribution.Simple.Program +import Distribution.Utils.Path + import Distribution.PackageDescription +import Distribution.Pretty +import Distribution.Simple.BuildWay import Distribution.Simple.Compiler +import Distribution.Simple.Flag +import Distribution.Simple.InstallDirs hiding + ( absoluteInstallDirs + , prefixRelativeInstallDirs + , substPathTemplate + ) import Distribution.Simple.PackageIndex -import Distribution.Simple.Setup +import Distribution.Simple.Program +import Distribution.Simple.Setup.Common +import Distribution.Simple.Setup.Config import Distribution.System -import Distribution.Pretty +import qualified Data.Map as Map import Distribution.Compat.Graph (Graph) import qualified Distribution.Compat.Graph as Graph -import qualified Data.Map as Map +import qualified System.FilePath as FilePath (takeDirectory) + -- | Data cached after configuration step. See also -- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - flagAssignment :: FlagAssignment, - -- ^ The final set of flags which were picked for this package - componentEnabledSpec :: ComponentRequestedSpec, - -- ^ What components were enabled during configuration, and why. - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various different - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - hostPlatform :: Platform, - -- ^ The platform we're building for - buildDir :: FilePath, - -- ^ Where to build the package. - cabalFilePath :: Maybe FilePath, - -- ^ Path to the cabal file, if given during configuration. - componentGraph :: Graph ComponentLocalBuildInfo, - -- ^ All the components to build, ordered by topological - -- sort, and with their INTERNAL dependencies over the - -- intrapackage dependency graph. - -- TODO: this is assumed to be short; otherwise we want - -- some sort of ordered map. - componentNameMap :: Map ComponentName [ComponentLocalBuildInfo], - -- ^ A map from component name to all matching - -- components. These coincide with 'componentGraph' - installedPkgs :: InstalledPackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - -- The copy saved on disk does NOT include internal - -- dependencies (because we just don't have enough - -- information at this point to have an - -- 'InstalledPackageInfo' for an internal dep), but we - -- will often update it with the internal dependencies; - -- see for example 'Distribution.Simple.Build.build'. - -- (This admonition doesn't apply for per-component builds.) - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ WARNING WARNING WARNING Be VERY careful about using - -- this function; we haven't deprecated it but using it - -- could introduce subtle bugs related to - -- 'HookedBuildInfo'. - -- - -- In principle, this is supposed to contain the - -- resolved package description, that does not contain - -- any conditionals. However, it MAY NOT contain - -- the description with a 'HookedBuildInfo' applied - -- to it; see 'HookedBuildInfo' for the whole sordid saga. - -- As much as possible, Cabal library should avoid using - -- this parameter. - withPrograms :: ProgramDb, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in) - withDynExe :: Bool, -- ^Whether to link executables dynamically - withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitSections :: Bool, -- ^Use -split-sections with GHC, if available - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - stripLibs :: Bool, -- ^Whether to strip libraries during install - exeCoverage :: Bool, -- ^Whether to enable executable program coverage - libCoverage :: Bool, -- ^Whether to enable library program coverage - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables - relocatable :: Bool -- ^Whether to build a relocatable package - } deriving (Generic, Read, Show, Typeable) +data LocalBuildInfo = NewLocalBuildInfo + { localBuildDescr :: LBC.LocalBuildDescr + -- ^ Information about a package determined by Cabal + -- after the configuration step. + , localBuildConfig :: LBC.LocalBuildConfig + -- ^ Information about a package configuration + -- that can be modified by the user at configuration time. + } + deriving (Generic, Read, Show) +{-# COMPLETE LocalBuildInfo #-} + +-- | This pattern synonym is for backwards compatibility, to adapt +-- to 'LocalBuildInfo' being split into 'LocalBuildDescr' and 'LocalBuildConfig'. +pattern LocalBuildInfo + :: ConfigFlags + -> FlagAssignment + -> ComponentRequestedSpec + -> [String] + -> InstallDirTemplates + -> Compiler + -> Platform + -> Maybe (SymbolicPath Pkg File) + -> Graph ComponentLocalBuildInfo + -> Map ComponentName [ComponentLocalBuildInfo] + -> Map (PackageName, ComponentName) PromisedComponent + -> InstalledPackageIndex + -> PackageDescription + -> ProgramDb + -> PackageDBStack + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> ProfDetailLevel + -> ProfDetailLevel + -> OptimisationLevel + -> DebugInfoLevel + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> Bool + -> [UnitId] + -> Bool + -> LocalBuildInfo +pattern LocalBuildInfo + { configFlags + , flagAssignment + , componentEnabledSpec + , extraConfigArgs + , installDirTemplates + , compiler + , hostPlatform + , pkgDescrFile + , componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + , localPkgDescr + , withPrograms + , withPackageDB + , withVanillaLib + , withProfLib + , withProfLibShared + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , extraCoverageFor + , relocatable + } = + NewLocalBuildInfo + { localBuildDescr = + LBC.LocalBuildDescr + { packageBuildDescr = + LBC.PackageBuildDescr + { configFlags + , flagAssignment + , componentEnabledSpec + , compiler + , hostPlatform + , localPkgDescr + , installDirTemplates + , withPackageDB + , pkgDescrFile + , extraCoverageFor + } + , componentBuildDescr = + LBC.ComponentBuildDescr + { componentGraph + , componentNameMap + , promisedPkgs + , installedPkgs + } + } + , localBuildConfig = + LBC.LocalBuildConfig + { extraConfigArgs + , withPrograms + , withBuildOptions = + LBC.BuildOptions + { withVanillaLib + , withProfLib + , withProfLibShared + , withSharedLib + , withStaticLib + , withDynExe + , withFullyStaticExe + , withProfExe + , withProfLibDetail + , withProfExeDetail + , withOptimization + , withDebugInfo + , withGHCiLib + , splitSections + , splitObjs + , stripExes + , stripLibs + , exeCoverage + , libCoverage + , relocatable + } + } + } + instance Binary LocalBuildInfo instance Structured LocalBuildInfo ------------------------------------------------------------------------------- -- Accessor functions +buildDir :: LocalBuildInfo -> SymbolicPath Pkg (Dir Build) +buildDir lbi = + buildDirPBD $ LBC.packageBuildDescr $ localBuildDescr lbi + +buildDirPBD :: LBC.PackageBuildDescr -> SymbolicPath Pkg (Dir Build) +buildDirPBD (LBC.PackageBuildDescr{configFlags = cfg}) = + setupFlagsBuildDir $ configCommonFlags cfg + +setupFlagsBuildDir :: CommonSetupFlags -> SymbolicPath Pkg (Dir Build) +setupFlagsBuildDir cfg = fromFlag (setupDistPref cfg) makeRelativePathEx "build" + +distPrefLBI :: LocalBuildInfo -> SymbolicPath Pkg (Dir Dist) +distPrefLBI = fromFlag . setupDistPref . configCommonFlags . LBC.configFlags . LBC.packageBuildDescr . localBuildDescr + +-- | The (relative or absolute) path to the package root, based on +-- +-- - the working directory flag +-- - the @.cabal@ path +packageRoot :: CommonSetupFlags -> FilePath +packageRoot cfg = + case flagToMaybe (setupCabalFilePath cfg) of + Just cabalPath -> FilePath.takeDirectory $ interpretSymbolicPath mbWorkDir cabalPath + Nothing -> maybe "." getSymbolicPath mbWorkDir + where + mbWorkDir = flagToMaybe $ setupWorkingDir cfg + +progPrefix, progSuffix :: LocalBuildInfo -> PathTemplate +progPrefix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgPrefix cfg +progSuffix (LocalBuildInfo{configFlags = cfg}) = + fromFlag $ configProgSuffix cfg + -- TODO: Get rid of these functions, as much as possible. They are -- a bit useful in some cases, but you should be very careful! @@ -173,71 +325,73 @@ -- on the package ID. localComponentId :: LocalBuildInfo -> ComponentId localComponentId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentComponentId = cid }] - -> cid - _ -> mkComponentId (prettyShow (localPackage lbi)) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentComponentId = cid}] -> + cid + _ -> mkComponentId (prettyShow (localPackage lbi)) -- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'. -- This is a "safe" use of 'localPkgDescr' localPackage :: LocalBuildInfo -> PackageId -localPackage lbi = package (localPkgDescr lbi) +localPackage (LocalBuildInfo{localPkgDescr = pkg}) = package pkg -- | Extract the 'UnitId' from the library component of a -- 'LocalBuildInfo' if it exists, or make a fake unit ID based on -- the package ID. localUnitId :: LocalBuildInfo -> UnitId localUnitId lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentUnitId = uid }] - -> uid - _ -> mkLegacyUnitId $ localPackage lbi + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentUnitId = uid}] -> + uid + _ -> mkLegacyUnitId $ localPackage lbi -- | Extract the compatibility package key from the public library component of a -- 'LocalBuildInfo' if it exists, or make a fake package key based -- on the package ID. localCompatPackageKey :: LocalBuildInfo -> String localCompatPackageKey lbi = - case componentNameCLBIs lbi (CLibName LMainLibName) of - [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }] - -> pk - _ -> prettyShow (localPackage lbi) + case componentNameCLBIs lbi (CLibName LMainLibName) of + [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] -> + pk + _ -> prettyShow (localPackage lbi) -- | Convenience function to generate a default 'TargetInfo' from a -- 'ComponentLocalBuildInfo'. The idea is to call this once, and then -- use 'TargetInfo' everywhere else. Private to this module. mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo mkTargetInfo pkg_descr _lbi clbi = - TargetInfo { - targetCLBI = clbi, - -- NB: @pkg_descr@, not @localPkgDescr lbi@! - targetComponent = getComponent pkg_descr - (componentLocalName clbi) - } + TargetInfo + { targetCLBI = clbi + , -- NB: @pkg_descr@, not @localPkgDescr lbi@! + targetComponent = + getComponent + pkg_descr + (componentLocalName clbi) + } -- | Return all 'TargetInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets' pkg_descr lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis - Nothing -> [] +componentNameTargets' pkg_descr lbi@(LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis + Nothing -> [] unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget' pkg_descr lbi uid = - case Graph.lookup uid (componentGraph lbi) of - Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) - Nothing -> Nothing +unitIdTarget' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uid = + case Graph.lookup uid compsGraph of + Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi) + Nothing -> Nothing -- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'. -- In the presence of Backpack there may be more than one! componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo] -componentNameCLBIs lbi cname = - case Map.lookup cname (componentNameMap lbi) of - Just clbis -> clbis - Nothing -> [] +componentNameCLBIs (LocalBuildInfo{componentNameMap = comps}) cname = + case Map.lookup cname comps of + Just clbis -> clbis + Nothing -> [] -- TODO: Maybe cache topsort (Graph can do this) @@ -246,24 +400,24 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder' pkg_descr lbi - = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi)) +allTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) = + map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort compsGraph) -- | Execute @f@ for every 'TargetInfo' in the package, respecting the -- build dependency order. (TODO: We should use Shake!) -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder' pkg_descr lbi f - = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ] +withAllTargetsInBuildOrder' pkg_descr lbi f = + sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi] -- | Return the list of all targets needed to build the @uids@, in -- the order they need to be built. -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder' pkg_descr lbi uids = - case Graph.closure (componentGraph lbi) uids of +neededTargetsInBuildOrder' pkg_descr lbi@(LocalBuildInfo{componentGraph = compsGraph}) uids = + case Graph.closure compsGraph uids of Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map prettyShow uids) Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos)) @@ -272,33 +426,77 @@ -- Has a prime because it takes a 'PackageDescription' argument -- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'. withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder' pkg_descr lbi uids f - = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ] +withNeededTargetsInBuildOrder' pkg_descr lbi uids f = + sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids] -- | Is coverage enabled for test suites? In practice, this requires library -- and executable profiling to be enabled. testCoverage :: LocalBuildInfo -> Bool -testCoverage lbi = exeCoverage lbi && libCoverage lbi +testCoverage (LocalBuildInfo{exeCoverage = exes, libCoverage = libs}) = + exes && libs +-- | Returns a list of ways, in the order which they should be built, and the +-- way we build executable and foreign library components. +-- +-- Ideally all this info should be fixed at configure time and not dependent on +-- additional info but `LocalBuildInfo` is per package (not per component) so it's +-- currently not possible to configure components to be built in certain ways. +buildWays :: LocalBuildInfo -> (Bool -> [BuildWay], Bool -> BuildWay, BuildWay) +buildWays lbi = + let + -- enable-library-profiling (enable (static profiling way)) .p_o + -- enable-shared (enabled dynamic way) .dyn_o + -- enable-profiling-shared (enable dynamic profilng way) .p_dyn_o + -- enable-library-vanilla (enable vanilla way) .o + -- + -- enable-executable-dynamic => build dynamic executables + -- => --enable-profiling + --enable-executable-dynamic => build dynamic profiled executables + -- => --enable-profiling => build vanilla profiled executables + + wantedLibWays is_indef = + [ProfDynWay | withProfLibShared lbi && not is_indef] + <> [ProfWay | withProfLib lbi] + -- I don't see why we shouldn't build with dynamic-- indefinite components. + <> [DynWay | withSharedLib lbi && not is_indef] + -- MP: Ideally we should have `BuildOptions` on a per component basis, in + -- which case this `is_indef` check could be moved to configure time. + <> [StaticWay | withVanillaLib lbi || withStaticLib lbi] + + wantedFLibWay is_dyn_flib = + case (is_dyn_flib, withProfExe lbi) of + (True, True) -> ProfDynWay + (False, True) -> ProfWay + (True, False) -> DynWay + (False, False) -> StaticWay + + wantedExeWay = + case (withDynExe lbi, withProfExe lbi) of + (True, True) -> ProfDynWay + (True, False) -> DynWay + (False, True) -> ProfWay + (False, False) -> StaticWay + in + (wantedLibWays, wantedFLibWay, wantedExeWay) + ------------------------------------------------------------------------------- -- Stub functions to prevent someone from accidentally defining them -{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PakcageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} - +{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-} componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo] -componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi - +componentNameTargets lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + componentNameTargets' pkg lbi unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo -unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi - +unitIdTarget lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + unitIdTarget' pkg lbi allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo] -allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi - +allTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + allTargetsInBuildOrder' pkg lbi withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO () -withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi - +withAllTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withAllTargetsInBuildOrder' pkg lbi neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo] -neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi - +neededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + neededTargetsInBuildOrder' pkg lbi withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO () -withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi +withNeededTargetsInBuildOrder lbi@(LocalBuildInfo{localPkgDescr = pkg}) = + withNeededTargetsInBuildOrder' pkg lbi diff --git a/src/Distribution/Types/Mixin.hs b/src/Distribution/Types/Mixin.hs deleted file mode 100644 --- a/src/Distribution/Types/Mixin.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.Mixin ( - Mixin(..), - mkMixin, - normaliseMixin, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.IncludeRenaming -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | --- --- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not --- the same as 'mixinPackageName'. In other words, --- the same invariant as 'Dependency' has. --- -data Mixin = Mixin { mixinPackageName :: PackageName - , mixinLibraryName :: LibraryName - , mixinIncludeRenaming :: IncludeRenaming } - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - -instance Binary Mixin -instance Structured Mixin - -instance NFData Mixin where rnf = genericRnf - -instance Pretty Mixin where - pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl - pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl - --- | --- --- >>> simpleParsec "mylib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:sublib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LSubLibName (UnqualComponentName "sublib"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- >>> simpleParsec "thatlib:thatlib" :: Maybe Mixin --- Just (Mixin {mixinPackageName = PackageName "thatlib", mixinLibraryName = LMainLibName, mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}}) --- --- Sublibrary syntax is accepted since @cabal-version: 3.4@. --- --- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin] --- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})] --- -instance Parsec Mixin where - parsec = do - pn <- parsec - ln <- P.option LMainLibName $ do - _ <- P.char ':' - versionGuardMultilibs - parsecWarning PWTExperimental "colon specifier is experimental feature (issue #5660)" - LSubLibName <$> parsec - P.spaces - incl <- parsec - return (mkMixin pn ln incl) - where - -versionGuardMultilibs :: CabalParsing m => m () -versionGuardMultilibs = do - csv <- askCabalSpecVersion - when (csv < CabalSpecV3_4) $ fail $ unwords - [ "Sublibrary mixin syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'." - ] - --- | Smart constructor of 'Mixin', enforces invariant. --- --- @since 3.4.0.0 -mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin -mkMixin pn (LSubLibName uqn) incl - | packageNameToUnqualComponentName pn == uqn - = Mixin pn LMainLibName incl -mkMixin pn ln incl - = Mixin pn ln incl - --- | Restore invariant -normaliseMixin :: Mixin -> Mixin -normaliseMixin (Mixin pn ln incl) = mkMixin pn ln incl diff --git a/src/Distribution/Types/Module.hs b/src/Distribution/Types/Module.hs deleted file mode 100644 --- a/src/Distribution/Types/Module.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Distribution.Types.Module - ( Module(..) - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.UnitId -import Distribution.ModuleName - --- | A module identity uniquely identifies a Haskell module by --- qualifying a 'ModuleName' with the 'UnitId' which defined --- it. This type distinguishes between two packages --- which provide a module with the same name, or a module --- from the same package compiled with different dependencies. --- There are a few cases where Cabal needs to know about --- module identities, e.g., when writing out reexported modules in --- the 'InstalledPackageInfo'. -data Module = - Module DefUnitId ModuleName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary Module -instance Structured Module - -instance Pretty Module where - pretty (Module uid mod_name) = - pretty uid <<>> Disp.text ":" <<>> pretty mod_name - -instance Parsec Module where - parsec = do - uid <- parsec - _ <- P.char ':' - mod_name <- parsec - return (Module uid mod_name) - -instance NFData Module where - rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name diff --git a/src/Distribution/Types/ModuleReexport.hs b/src/Distribution/Types/ModuleReexport.hs deleted file mode 100644 --- a/src/Distribution/Types/ModuleReexport.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.ModuleReexport ( - ModuleReexport(..) -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ----------------------------------------------------------------------------- --- Module re-exports - -data ModuleReexport = ModuleReexport { - moduleReexportOriginalPackage :: Maybe PackageName, - moduleReexportOriginalName :: ModuleName, - moduleReexportName :: ModuleName - } - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary ModuleReexport -instance Structured ModuleReexport -instance NFData ModuleReexport where rnf = genericRnf - -instance Pretty ModuleReexport where - pretty (ModuleReexport mpkgname origname newname) = - maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname - <<>> pretty origname - <+> if newname == origname - then Disp.empty - else Disp.text "as" <+> pretty newname - -instance Parsec ModuleReexport where - parsec = do - mpkgname <- P.optional (P.try $ parsec <* P.char ':') - origname <- parsec - newname <- P.option origname $ P.try $ do - P.spaces - _ <- P.string "as" - P.spaces - parsec - return (ModuleReexport mpkgname origname newname) diff --git a/src/Distribution/Types/ModuleRenaming.hs b/src/Distribution/Types/ModuleRenaming.hs deleted file mode 100644 --- a/src/Distribution/Types/ModuleRenaming.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RankNTypes #-} - -module Distribution.Types.ModuleRenaming ( - ModuleRenaming(..), - interpModuleRenaming, - defaultRenaming, - isDefaultRenaming, -) where - -import Distribution.CabalSpecVersion -import Distribution.Compat.Prelude hiding (empty) -import Prelude () - -import Distribution.ModuleName -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Distribution.Compat.CharParsing as P -import Text.PrettyPrint (hsep, parens, punctuate, text, comma) - --- | Renaming applied to the modules provided by a package. --- The boolean indicates whether or not to also include all of the --- original names of modules. Thus, @ModuleRenaming False []@ is --- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@ --- is, "expose all modules, but also expose @Data.Bool@ as @Bool@". --- If a renaming is omitted you get the 'DefaultRenaming'. --- --- (NB: This is a list not a map so that we can preserve order.) --- -data ModuleRenaming - -- | A module renaming/thinning; e.g., @(A as B, C as C)@ - -- brings @B@ and @C@ into scope. - = ModuleRenaming [(ModuleName, ModuleName)] - -- | The default renaming, bringing all exported modules - -- into scope. - | DefaultRenaming - -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all - -- exported modules into scope except the hidden ones. - | HidingRenaming [ModuleName] - deriving (Show, Read, Eq, Ord, Typeable, Data, Generic) - --- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName' --- to 'ModuleName'. For efficiency, you should partially apply it --- with 'ModuleRenaming' and then reuse it. -interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName -interpModuleRenaming DefaultRenaming = Just -interpModuleRenaming (ModuleRenaming rns) = - let m = Map.fromList rns - in \k -> Map.lookup k m -interpModuleRenaming (HidingRenaming hs) = - let s = Set.fromList hs - in \k -> if k `Set.member` s then Nothing else Just k - --- | The default renaming, if something is specified in @build-depends@ --- only. -defaultRenaming :: ModuleRenaming -defaultRenaming = DefaultRenaming - --- | Tests if its the default renaming; we can use a more compact syntax --- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case. -isDefaultRenaming :: ModuleRenaming -> Bool -isDefaultRenaming DefaultRenaming = True -isDefaultRenaming _ = False - - - -instance Binary ModuleRenaming where -instance Structured ModuleRenaming where - -instance NFData ModuleRenaming where rnf = genericRnf - --- NB: parentheses are mandatory, because later we may extend this syntax --- to allow "hiding (A, B)" or other modifier words. -instance Pretty ModuleRenaming where - pretty DefaultRenaming = mempty - pretty (HidingRenaming hides) - = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides))) - pretty (ModuleRenaming rns) - = parens . hsep $ punctuate comma (map dispEntry rns) - where dispEntry (orig, new) - | orig == new = pretty orig - | otherwise = pretty orig <+> text "as" <+> pretty new - -instance Parsec ModuleRenaming where - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then moduleRenamingParsec parensLax lexemeParsec - else moduleRenamingParsec parensStrict parsec - where - -- For cabal spec versions < 3.0 white spaces were not skipped - -- after the '(' and ')' tokens in the mixin field. This - -- parser checks the cabal file version and does the correct - -- skipping of spaces. - parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p - parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p - - warnSpaces = P.optional $ - P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher" - -moduleRenamingParsec - :: CabalParsing m - => (forall a. m a -> m a) -- ^ between parens - -> m ModuleName -- ^ module name parser - -> m ModuleRenaming -moduleRenamingParsec bp mn = - -- NB: try not necessary as the first token is obvious - P.choice [ parseRename, parseHiding, return DefaultRenaming ] - where - cma = P.char ',' >> P.spaces - parseRename = do - rns <- bp parseList - P.spaces - return (ModuleRenaming rns) - parseHiding = do - _ <- P.string "hiding" - P.spaces -- space isn't strictly required as next is an open paren - hides <- bp (P.sepBy mn cma) - return (HidingRenaming hides) - parseList = - P.sepBy parseEntry cma - parseEntry = do - orig <- parsec - P.spaces - P.option (orig, orig) $ do - _ <- P.string "as" - P.skipSpaces1 -- require space after "as" - new <- parsec - P.spaces - return (orig, new) diff --git a/src/Distribution/Types/MungedPackageId.hs b/src/Distribution/Types/MungedPackageId.hs deleted file mode 100644 --- a/src/Distribution/Types/MungedPackageId.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageId - ( MungedPackageId(..) - , computeCompatPackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.MungedPackageName -import Distribution.Types.PackageId -import Distribution.Version (Version, nullVersion) - -import qualified Text.PrettyPrint as Disp - --- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to --- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more --- info. -data MungedPackageId - = MungedPackageId { - -- | The combined package and component name. see documentation for - -- 'MungedPackageName'. - mungedName :: MungedPackageName, - -- | The version of this package / component, eg 1.2 - mungedVersion :: Version - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageId -instance Structured MungedPackageId - --- | --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" LMainLibName) (mkVersion [1,2,3]) --- "servant-1.2.3" --- --- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2]) --- "z-servant-z-lackey-0.1.2" --- -instance Pretty MungedPackageId where - pretty (MungedPackageId n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") LMainLibName, mungedVersion = mkVersion []}) --- --- >>> simpleParsec "z-foo-bar-z-baz-0" :: Maybe MungedPackageId --- Just (MungedPackageId {mungedName = MungedPackageName (PackageName "foo-bar") (LSubLibName (UnqualComponentName "baz")), mungedVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe MungedPackageId --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId --- Nothing --- -instance Parsec MungedPackageId where - parsec = do - PackageIdentifier pn v <- parsec - return $ MungedPackageId (decodeCompatPackageName pn) v - -instance NFData MungedPackageId where - rnf (MungedPackageId name version) = rnf name `seq` rnf version - -computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId -computeCompatPackageId (PackageIdentifier pn vr) ln = - MungedPackageId (MungedPackageName pn ln) vr - --- $setup --- >>> :seti -XOverloadedStrings --- >>> import Distribution.Types.Version diff --git a/src/Distribution/Types/MungedPackageName.hs b/src/Distribution/Types/MungedPackageName.hs deleted file mode 100644 --- a/src/Distribution/Types/MungedPackageName.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.MungedPackageName - ( MungedPackageName (..) - , decodeCompatPackageName - , encodeCompatPackageName - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.LibraryName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A combination of a package and component name used in various legacy --- interfaces, chiefly bundled with a version as 'MungedPackageId'. It's generally --- better to use a 'UnitId' to opaquely refer to some compilation/packing unit, --- but that doesn't always work, e.g. where a "name" is needed, in which case --- this can be used as a fallback. --- --- Use 'mkMungedPackageName' and 'unMungedPackageName' to convert from/to a 'String'. --- --- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation. --- --- @since 2.0.0.2 --- -data MungedPackageName = MungedPackageName !PackageName !LibraryName - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary MungedPackageName -instance Structured MungedPackageName -instance NFData MungedPackageName where rnf = genericRnf - --- | Computes the package name for a library. If this is the public --- library, it will just be the original package name; otherwise, --- it will be a munged package name recording the original package --- name as well as the name of the internal library. --- --- A lot of tooling in the Haskell ecosystem assumes that if something --- is installed to the package database with the package name 'foo', --- then it actually is an entry for the (only public) library in package --- 'foo'. With internal packages, this is not necessarily true: --- a public library as well as arbitrarily many internal libraries may --- come from the same package. To prevent tools from getting confused --- in this case, the package name of these internal libraries is munged --- so that they do not conflict the public library proper. A particular --- case where this matters is ghc-pkg: if we don't munge the package --- name, the inplace registration will OVERRIDE a different internal --- library. --- --- We munge into a reserved namespace, "z-", and encode both the --- component name and the package name of an internal library using the --- following format: --- --- compat-pkg-name ::= "z-" package-name "-z-" library-name --- --- where package-name and library-name have "-" ( "z" + ) "-" --- segments encoded by adding an extra "z". --- --- When we have the public library, the compat-pkg-name is just the --- package-name, no surprises there! --- --- >>> prettyShow $ MungedPackageName "servant" LMainLibName --- "servant" --- --- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey") --- "z-servant-z-lackey" --- -instance Pretty MungedPackageName where - -- First handle the cases where we can just use the original 'PackageName'. - -- This is for the PRIMARY library, and it is non-Backpack, or the - -- indefinite package for us. - pretty = Disp.text . encodeCompatPackageName' - --- | --- --- >>> simpleParsec "servant" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") LMainLibName) --- --- >>> simpleParsec "z-servant-z-lackey" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))) --- --- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName --- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName) --- -instance Parsec MungedPackageName where - parsec = decodeCompatPackageName' <$> parsecUnqualComponentName - -------------------------------------------------------------------------------- --- ZDashCode conversions -------------------------------------------------------------------------------- - --- | Intended for internal use only --- --- >>> decodeCompatPackageName "z-servant-z-lackey" --- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey")) --- -decodeCompatPackageName :: PackageName -> MungedPackageName -decodeCompatPackageName = decodeCompatPackageName' . unPackageName - --- | Intended for internal use only --- --- >>> encodeCompatPackageName $ MungedPackageName "servant" (LSubLibName "lackey") --- PackageName "z-servant-z-lackey" --- --- This is used in @cabal-install@ in the Solver. --- May become obsolete as solver moves to per-component solving. --- -encodeCompatPackageName :: MungedPackageName -> PackageName -encodeCompatPackageName = mkPackageName . encodeCompatPackageName' - -decodeCompatPackageName' :: String -> MungedPackageName -decodeCompatPackageName' m = - case m of - 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest - -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn)) - s -> MungedPackageName (mkPackageName s) LMainLibName - -encodeCompatPackageName' :: MungedPackageName -> String -encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn -encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) = - "z-" ++ zdashcode (unPackageName pn) ++ - "-z-" ++ zdashcode (unUnqualComponentName uqn) - -zdashcode :: String -> String -zdashcode s = go s (Nothing :: Maybe Int) [] - where go [] _ r = reverse r - go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r) - go ('-':z) _ r = go z (Just 0) ('-':r) - go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r) - go (c:z) _ r = go z Nothing (c:r) - -parseZDashCode :: CabalParsing m => m [String] -parseZDashCode = do - ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-') - return (go ns) - where - go ns = case break (=="z") ns of - (_, []) -> [paste ns] - (as, "z":bs) -> paste as : go bs - _ -> error "parseZDashCode: go" - unZ :: String -> String - unZ "" = error "parseZDashCode: unZ" - unZ r@('z':zs) | all (=='z') zs = zs - | otherwise = r - unZ r = r - paste :: [String] -> String - paste = intercalate "-" . map unZ - --- $setup --- >>> :seti -XOverloadedStrings diff --git a/src/Distribution/Types/PackageDescription.hs b/src/Distribution/Types/PackageDescription.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageDescription.hs +++ /dev/null @@ -1,457 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Types.PackageDescription --- Copyright : Isaac Jones 2003-2005 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the data structure for the @.cabal@ file format. There are --- several parts to this structure. It has top level info and then 'Library', --- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have --- associated 'BuildInfo' data that's used to build the library, exe, test, or --- benchmark. To further complicate things there is both a 'PackageDescription' --- and a 'GenericPackageDescription'. This distinction relates to cabal --- configurations. When we initially read a @.cabal@ file we get a --- 'GenericPackageDescription' which has all the conditional sections. --- Before actually building a package we have to decide --- on each conditional. Once we've done that we get a 'PackageDescription'. --- It was done this way initially to avoid breaking too much stuff when the --- feature was introduced. It could probably do with being rationalised at some --- point to make it simpler. - -module Distribution.Types.PackageDescription ( - PackageDescription(..), - license, - license', - buildType, - emptyPackageDescription, - hasPublicLib, - hasLibs, - allLibraries, - withLib, - hasExes, - withExe, - hasTests, - withTest, - hasBenchmarks, - withBenchmark, - hasForeignLibs, - withForeignLib, - allBuildInfo, - enabledBuildInfos, - allBuildDepends, - enabledBuildDepends, - updatePackageDescription, - pkgComponents, - pkgBuildableComponents, - enabledComponents, - lookupComponent, - getComponent, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Control.Monad ((<=<)) - --- lens -import qualified Distribution.Types.BuildInfo.Lens as L -import Distribution.Types.Library -import Distribution.Types.TestSuite -import Distribution.Types.Executable -import Distribution.Types.Benchmark -import Distribution.Types.ForeignLib - -import Distribution.Types.Component -import Distribution.Types.ComponentRequestedSpec -import Distribution.Types.Dependency -import Distribution.Types.PackageId -import Distribution.Types.ComponentName -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName -import Distribution.Types.SetupBuildInfo -import Distribution.Types.BuildInfo -import Distribution.Types.BuildType -import Distribution.Types.SourceRepo -import Distribution.Types.HookedBuildInfo - -import Distribution.CabalSpecVersion -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.Version -import Distribution.Utils.Path -import Distribution.Utils.ShortText - -import qualified Distribution.SPDX as SPDX - --- ----------------------------------------------------------------------------- --- The PackageDescription type - --- | This data type is the internal representation of the file @pkg.cabal@. --- It contains two kinds of information about the package: information --- which is needed for all packages, such as the package name and version, and --- information which is needed for the simple build system only, such as --- the compiler options and library name. --- -data PackageDescription - = PackageDescription { - -- the following are required by all packages: - - -- | The version of the Cabal spec that this package description uses. - specVersion :: CabalSpecVersion, - package :: PackageIdentifier, - licenseRaw :: Either SPDX.License License, - licenseFiles :: [SymbolicPath PackageDir LicenseFile], - copyright :: !ShortText, - maintainer :: !ShortText, - author :: !ShortText, - stability :: !ShortText, - testedWith :: [(CompilerFlavor,VersionRange)], - homepage :: !ShortText, - pkgUrl :: !ShortText, - bugReports :: !ShortText, - sourceRepos :: [SourceRepo], - synopsis :: !ShortText, -- ^A one-line summary of this package - description :: !ShortText, -- ^A more verbose description of this package - category :: !ShortText, - customFieldsPD :: [(String,String)], -- ^Custom fields starting - -- with x-, stored in a - -- simple assoc-list. - - -- | The original @build-type@ value as parsed from the - -- @.cabal@ file without defaulting. See also 'buildType'. - -- - -- @since 2.2 - buildTypeRaw :: Maybe BuildType, - setupBuildInfo :: Maybe SetupBuildInfo, - -- components - library :: Maybe Library, - subLibraries :: [Library], - executables :: [Executable], - foreignLibs :: [ForeignLib], - testSuites :: [TestSuite], - benchmarks :: [Benchmark], - -- files - dataFiles :: [FilePath], - dataDir :: FilePath, - extraSrcFiles :: [FilePath], - extraTmpFiles :: [FilePath], - extraDocFiles :: [FilePath] - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary PackageDescription -instance Structured PackageDescription - -instance NFData PackageDescription where rnf = genericRnf - -instance Package PackageDescription where - packageId = package - --- | The SPDX 'LicenseExpression' of the package. --- --- @since 2.2.0.0 -license :: PackageDescription -> SPDX.License -license = license' . licenseRaw - --- | See 'license'. --- --- @since 2.2.0.0 -license' :: Either SPDX.License License -> SPDX.License -license' = either id licenseToSPDX - --- | The effective @build-type@ after applying defaulting rules. --- --- The original @build-type@ value parsed is stored in the --- 'buildTypeRaw' field. However, the @build-type@ field is optional --- and can therefore be empty in which case we need to compute the --- /effective/ @build-type@. This function implements the following --- defaulting rules: --- --- * For @cabal-version:2.0@ and below, default to the @Custom@ --- build-type unconditionally. --- --- * Otherwise, if a @custom-setup@ stanza is defined, default to --- the @Custom@ build-type; else default to @Simple@ build-type. --- --- @since 2.2 -buildType :: PackageDescription -> BuildType -buildType pkg - | specVersion pkg >= CabalSpecV2_2 - = fromMaybe newDefault (buildTypeRaw pkg) - | otherwise -- cabal-version < 2.1 - = fromMaybe Custom (buildTypeRaw pkg) - where - newDefault | isNothing (setupBuildInfo pkg) = Simple - | otherwise = Custom - -emptyPackageDescription :: PackageDescription -emptyPackageDescription - = PackageDescription { - package = PackageIdentifier (mkPackageName "") - nullVersion, - licenseRaw = Right UnspecifiedLicense, -- TODO: - licenseFiles = [], - specVersion = CabalSpecV1_0, - buildTypeRaw = Nothing, - copyright = mempty, - maintainer = mempty, - author = mempty, - stability = mempty, - testedWith = [], - homepage = mempty, - pkgUrl = mempty, - bugReports = mempty, - sourceRepos = [], - synopsis = mempty, - description = mempty, - category = mempty, - customFieldsPD = [], - setupBuildInfo = Nothing, - library = Nothing, - subLibraries = [], - foreignLibs = [], - executables = [], - testSuites = [], - benchmarks = [], - dataFiles = [], - dataDir = ".", - extraSrcFiles = [], - extraTmpFiles = [], - extraDocFiles = [] - } - --- --------------------------------------------------------------------------- --- The Library type - --- | Does this package have a buildable PUBLIC library? -hasPublicLib :: PackageDescription -> Bool -hasPublicLib p = - case library p of - Just lib -> buildable (libBuildInfo lib) - Nothing -> False - --- | Does this package have any libraries? -hasLibs :: PackageDescription -> Bool -hasLibs p = any (buildable . libBuildInfo) (allLibraries p) - -allLibraries :: PackageDescription -> [Library] -allLibraries p = maybeToList (library p) ++ subLibraries p - --- | If the package description has a buildable library section, --- call the given function with the library build info as argument. --- You probably want 'withLibLBI' if you have a 'LocalBuildInfo', --- see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withLib :: PackageDescription -> (Library -> IO ()) -> IO () -withLib pkg_descr f = - sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)] - --- --------------------------------------------------------------------------- --- The Executable type - --- |does this package have any executables? -hasExes :: PackageDescription -> Bool -hasExes p = any (buildable . buildInfo) (executables p) - --- | Perform the action on each buildable 'Executable' in the package --- description. You probably want 'withExeLBI' if you have a --- 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. -withExe :: PackageDescription -> (Executable -> IO ()) -> IO () -withExe pkg_descr f = - sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] - --- --------------------------------------------------------------------------- --- The TestSuite type - --- | Does this package have any test suites? -hasTests :: PackageDescription -> Bool -hasTests = any (buildable . testBuildInfo) . testSuites - --- | Perform an action on each buildable 'TestSuite' in a package. --- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () -withTest pkg_descr f = - sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ] - --- --------------------------------------------------------------------------- --- The Benchmark type - --- | Does this package have any benchmarks? -hasBenchmarks :: PackageDescription -> Bool -hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks - --- | Perform an action on each buildable 'Benchmark' in a package. --- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in --- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components" --- for more information. - -withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO () -withBenchmark pkg_descr f = - sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)] - --- --------------------------------------------------------------------------- --- The ForeignLib type - --- | Does this package have any foreign libraries? -hasForeignLibs :: PackageDescription -> Bool -hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p) - --- | Perform the action on each buildable 'ForeignLib' in the package --- description. -withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO () -withForeignLib pkg_descr f = - sequence_ [ f flib - | flib <- foreignLibs pkg_descr - , buildable (foreignLibBuildInfo flib) - ] - --- --------------------------------------------------------------------------- --- The BuildInfo type - --- | All 'BuildInfo' in the 'PackageDescription': --- libraries, executables, test-suites and benchmarks. --- --- Useful for implementing package checks. -allBuildInfo :: PackageDescription -> [BuildInfo] -allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr - , let bi = libBuildInfo lib ] - ++ [ bi | flib <- foreignLibs pkg_descr - , let bi = foreignLibBuildInfo flib ] - ++ [ bi | exe <- executables pkg_descr - , let bi = buildInfo exe ] - ++ [ bi | tst <- testSuites pkg_descr - , let bi = testBuildInfo tst ] - ++ [ bi | tst <- benchmarks pkg_descr - , let bi = benchmarkBuildInfo tst ] - --- | Return all of the 'BuildInfo's of enabled components, i.e., all of --- the ones that would be built if you run @./Setup build@. -enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo] -enabledBuildInfos pkg enabled = - [ componentBuildInfo comp - | comp <- enabledComponents pkg enabled ] - - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - --- | Get the combined build-depends entries of all components. -allBuildDepends :: PackageDescription -> [Dependency] -allBuildDepends = targetBuildDepends <=< allBuildInfo - --- | Get the combined build-depends entries of all enabled components, per the --- given request spec. -enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] -enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd - - -updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription -updatePackageDescription (mb_lib_bi, exe_bi) p - = p{ executables = updateExecutables exe_bi (executables p) - , library = updateLibrary mb_lib_bi (library p) } - where - updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library - updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) - updateLibrary Nothing mb_lib = mb_lib - updateLibrary (Just _) Nothing = Nothing - - updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)] - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeNames updated - updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' - - updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo) - -> [Executable] -- ^list of executables to update - -> [Executable] -- ^list with exeName updated - updateExecutable _ [] = [] - updateExecutable exe_bi'@(name,bi) (exe:exes) - | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes - | otherwise = exe : updateExecutable exe_bi' exes - --- ----------------------------------------------------------------------------- --- Source-representation of buildable components - --- | All the components in the package. --- -pkgComponents :: PackageDescription -> [Component] -pkgComponents pkg = - [ CLib lib | lib <- allLibraries pkg ] - ++ [ CFLib flib | flib <- foreignLibs pkg ] - ++ [ CExe exe | exe <- executables pkg ] - ++ [ CTest tst | tst <- testSuites pkg ] - ++ [ CBench bm | bm <- benchmarks pkg ] - --- | A list of all components in the package that are buildable, --- i.e., were not marked with @buildable: False@. This does NOT --- indicate if we are actually going to build the component, --- see 'enabledComponents' instead. --- --- @since 2.0.0.2 --- -pkgBuildableComponents :: PackageDescription -> [Component] -pkgBuildableComponents = filter componentBuildable . pkgComponents - --- | A list of all components in the package that are enabled. --- --- @since 2.0.0.2 --- -enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component] -enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg - -lookupComponent :: PackageDescription -> ComponentName -> Maybe Component -lookupComponent pkg (CLibName name) = - fmap CLib $ find ((name ==) . libName) (allLibraries pkg) -lookupComponent pkg (CFLibName name) = - fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg) -lookupComponent pkg (CExeName name) = - fmap CExe $ find ((name ==) . exeName) (executables pkg) -lookupComponent pkg (CTestName name) = - fmap CTest $ find ((name ==) . testName) (testSuites pkg) -lookupComponent pkg (CBenchName name) = - fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) - -getComponent :: PackageDescription -> ComponentName -> Component -getComponent pkg cname = - case lookupComponent pkg cname of - Just cpnt -> cpnt - Nothing -> missingComponent - where - missingComponent = - error $ "internal error: the package description contains no " - ++ "component corresponding to " ++ show cname - --- ----------------------------------------------------------------------------- --- Traversal Instances - -instance L.HasBuildInfos PackageDescription where - traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - x1 x2 x3 x4 x5 x6 - a20 a21 a22 a23 a24) = - PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 - <$> (traverse . L.buildInfo) f x1 -- library - <*> (traverse . L.buildInfo) f x2 -- sub libraries - <*> (traverse . L.buildInfo) f x3 -- executables - <*> (traverse . L.buildInfo) f x4 -- foreign libs - <*> (traverse . L.buildInfo) f x5 -- test suites - <*> (traverse . L.buildInfo) f x6 -- benchmarks - <*> pure a20 -- data files - <*> pure a21 -- data dir - <*> pure a22 -- extra src files - <*> pure a23 -- extra temp files - <*> pure a24 -- extra doc files diff --git a/src/Distribution/Types/PackageDescription/Lens.hs b/src/Distribution/Types/PackageDescription/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageDescription/Lens.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -module Distribution.Types.PackageDescription.Lens ( - PackageDescription, - module Distribution.Types.PackageDescription.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion (CabalSpecVersion) -import Distribution.Compiler (CompilerFlavor) -import Distribution.License (License) -import Distribution.ModuleName (ModuleName) -import Distribution.Types.Benchmark (Benchmark, benchmarkModules) -import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.BuildType (BuildType) -import Distribution.Types.ComponentName (ComponentName (..)) -import Distribution.Types.Executable (Executable, exeModules) -import Distribution.Types.Executable.Lens (exeBuildInfo, exeName) -import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) -import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) -import Distribution.Types.Library (Library, explicitLibModules) -import Distribution.Types.Library.Lens (libBuildInfo, libName) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) -import Distribution.Types.SourceRepo (SourceRepo) -import Distribution.Types.TestSuite (TestSuite, testModules) -import Distribution.Types.TestSuite.Lens (testBuildInfo, testName) -import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath) -import Distribution.Utils.ShortText (ShortText) -import Distribution.Version (VersionRange) - -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Types.PackageDescription as T - -package :: Lens' PackageDescription PackageIdentifier -package f s = fmap (\x -> s { T.package = x }) (f (T.package s)) -{-# INLINE package #-} - -licenseRaw :: Lens' PackageDescription (Either SPDX.License License) -licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s)) -{-# INLINE licenseRaw #-} - -licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile] -licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s)) -{-# INLINE licenseFiles #-} - -copyright :: Lens' PackageDescription ShortText -copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s)) -{-# INLINE copyright #-} - -maintainer :: Lens' PackageDescription ShortText -maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s)) -{-# INLINE maintainer #-} - -author :: Lens' PackageDescription ShortText -author f s = fmap (\x -> s { T.author = x }) (f (T.author s)) -{-# INLINE author #-} - -stability :: Lens' PackageDescription ShortText -stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s)) -{-# INLINE stability #-} - -testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)] -testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s)) -{-# INLINE testedWith #-} - -homepage :: Lens' PackageDescription ShortText -homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s)) -{-# INLINE homepage #-} - -pkgUrl :: Lens' PackageDescription ShortText -pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s)) -{-# INLINE pkgUrl #-} - -bugReports :: Lens' PackageDescription ShortText -bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s)) -{-# INLINE bugReports #-} - -sourceRepos :: Lens' PackageDescription [SourceRepo] -sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s)) -{-# INLINE sourceRepos #-} - -synopsis :: Lens' PackageDescription ShortText -synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s)) -{-# INLINE synopsis #-} - -description :: Lens' PackageDescription ShortText -description f s = fmap (\x -> s { T.description = x }) (f (T.description s)) -{-# INLINE description #-} - -category :: Lens' PackageDescription ShortText -category f s = fmap (\x -> s { T.category = x }) (f (T.category s)) -{-# INLINE category #-} - -customFieldsPD :: Lens' PackageDescription [(String,String)] -customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s)) -{-# INLINE customFieldsPD #-} - -specVersion :: Lens' PackageDescription CabalSpecVersion -specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s)) -{-# INLINE specVersion #-} - -buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) -buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s)) -{-# INLINE buildTypeRaw #-} - -setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) -setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s)) -{-# INLINE setupBuildInfo #-} - -library :: Lens' PackageDescription (Maybe Library) -library f s = fmap (\x -> s { T.library = x }) (f (T.library s)) -{-# INLINE library #-} - -subLibraries :: Lens' PackageDescription [Library] -subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s)) -{-# INLINE subLibraries #-} - -executables :: Lens' PackageDescription [Executable] -executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s)) -{-# INLINE executables #-} - -foreignLibs :: Lens' PackageDescription [ForeignLib] -foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s)) -{-# INLINE foreignLibs #-} - -testSuites :: Lens' PackageDescription [TestSuite] -testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s)) -{-# INLINE testSuites #-} - -benchmarks :: Lens' PackageDescription [Benchmark] -benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s)) -{-# INLINE benchmarks #-} - -dataFiles :: Lens' PackageDescription [FilePath] -dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s)) -{-# INLINE dataFiles #-} - -dataDir :: Lens' PackageDescription FilePath -dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s)) -{-# INLINE dataDir #-} - -extraSrcFiles :: Lens' PackageDescription [String] -extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s)) -{-# INLINE extraSrcFiles #-} - -extraTmpFiles :: Lens' PackageDescription [String] -extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s)) -{-# INLINE extraTmpFiles #-} - -extraDocFiles :: Lens' PackageDescription [String] -extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s)) -{-# INLINE extraDocFiles #-} - --- | @since 3.0.0.0 -allLibraries :: Traversal' PackageDescription Library -allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) - where - mk l ls = pd { T.library = l, T.subLibraries = ls } - --- | @since 2.4 -componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] -componentModules cname = case cname of - CLibName name -> - componentModules' name allLibraries libName explicitLibModules - CFLibName name -> - componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules - CExeName name -> - componentModules' name (executables . traverse) exeName exeModules - CTestName name -> - componentModules' name (testSuites . traverse) testName testModules - CBenchName name -> - componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules - where - componentModules' - :: (Eq name, Monoid r) - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> (a -> [ModuleName]) - -> Getting r PackageDescription [ModuleName] - componentModules' name pdL nameL modules = - pdL - . filtered ((== name) . view nameL) - . getting modules - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s - --- | @since 2.4 -componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo -componentBuildInfo cname = case cname of - CLibName name -> - componentBuildInfo' name allLibraries libName libBuildInfo - CFLibName name -> - componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo - CExeName name -> - componentBuildInfo' name (executables . traverse) exeName exeBuildInfo - CTestName name -> - componentBuildInfo' name (testSuites . traverse) testName testBuildInfo - CBenchName name -> - componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo - where - componentBuildInfo' :: Eq name - => name - -> Traversal' PackageDescription a - -> Lens' a name - -> Traversal' a BuildInfo - -> Traversal' PackageDescription BuildInfo - componentBuildInfo' name pdL nameL biL = - pdL - . filtered ((== name) . view nameL) - . biL - - filtered :: (a -> Bool) -> Traversal' a a - filtered p f s = if p s then f s else pure s diff --git a/src/Distribution/Types/PackageId.hs b/src/Distribution/Types/PackageId.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageId.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageId - ( PackageIdentifier(..) - , PackageId - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec (Parsec (..), simpleParsec) -import Distribution.Pretty -import Distribution.Types.PackageName -import Distribution.Version (Version, nullVersion) - -import qualified Data.List.NonEmpty as NE -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | Type alias so we can use the shorter name PackageId. -type PackageId = PackageIdentifier - --- | The name and version of a package. -data PackageIdentifier - = PackageIdentifier { - pkgName :: PackageName, -- ^The name of this package, eg. foo - pkgVersion :: Version -- ^the version of this package, eg 1.2 - } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - -instance Binary PackageIdentifier -instance Structured PackageIdentifier - -instance Pretty PackageIdentifier where - pretty (PackageIdentifier n v) - | v == nullVersion = pretty n -- if no version, don't show version. - | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v - --- | --- --- >>> simpleParsec "foo-bar-0" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion [0]}) --- --- >>> simpleParsec "foo-bar" :: Maybe PackageIdentifier --- Just (PackageIdentifier {pkgName = PackageName "foo-bar", pkgVersion = mkVersion []}) --- --- /Note:/ Stricter than 'Text' instance --- --- >>> simpleParsec "foo-bar-0-0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.0" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "foo-bar.4-2" :: Maybe PackageIdentifier --- Nothing --- --- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier --- Nothing --- -instance Parsec PackageIdentifier where - parsec = do - xs' <- P.sepByNonEmpty component (P.char '-') - (v, xs) <- case simpleParsec (NE.last xs') of - Nothing -> return (nullVersion, toList xs') -- all components are version - Just v -> return (v, NE.init xs') - if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs - then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v - else fail "all digits or a dot in a portion of package name" - where - component = P.munch1 (\c -> isAlphaNum c || c == '.') - -instance NFData PackageIdentifier where - rnf (PackageIdentifier name version) = rnf name `seq` rnf version diff --git a/src/Distribution/Types/PackageId/Lens.hs b/src/Distribution/Types/PackageId/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageId/Lens.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Distribution.Types.PackageId.Lens ( - PackageIdentifier, - module Distribution.Types.PackageId.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PackageId (PackageIdentifier) -import Distribution.Types.PackageName (PackageName) -import Distribution.Version (Version) - -import qualified Distribution.Types.PackageId as T - -pkgName :: Lens' PackageIdentifier PackageName -pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s)) -{-# INLINE pkgName #-} - -pkgVersion :: Lens' PackageIdentifier Version -pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s)) -{-# INLINE pkgVersion #-} diff --git a/src/Distribution/Types/PackageName.hs b/src/Distribution/Types/PackageName.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageName.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageName - ( PackageName - , unPackageName, mkPackageName - , unPackageNameST, mkPackageNameST - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Text.PrettyPrint as Disp -import Distribution.Pretty -import Distribution.Parsec - --- | A package name. --- --- Use 'mkPackageName' and 'unPackageName' to convert from/to a --- 'String'. --- --- This type is opaque since @Cabal-2.0@ --- --- @since 2.0.0.2 -newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PackageName' to 'String' -unPackageName :: PackageName -> String -unPackageName (PackageName s) = fromShortText s - --- | @since 3.4.0.0 -unPackageNameST :: PackageName -> ShortText -unPackageNameST (PackageName s) = s - --- | Construct a 'PackageName' from a 'String' --- --- 'mkPackageName' is the inverse to 'unPackageName' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 2.0.0.2 -mkPackageName :: String -> PackageName -mkPackageName = PackageName . toShortText - --- | Construct a 'PackageName' from a 'ShortText' --- --- Note: No validations are performed to ensure that the resulting --- 'PackageName' is valid --- --- @since 3.4.0.0 -mkPackageNameST :: ShortText -> PackageName -mkPackageNameST = PackageName - --- | 'mkPackageName' --- --- @since 2.0.0.2 -instance IsString PackageName where - fromString = mkPackageName - -instance Binary PackageName -instance Structured PackageName - -instance Pretty PackageName where - pretty = Disp.text . unPackageName - -instance Parsec PackageName where - parsec = mkPackageName <$> parsecUnqualComponentName - -instance NFData PackageName where - rnf (PackageName pkg) = rnf pkg diff --git a/src/Distribution/Types/PackageName/Magic.hs b/src/Distribution/Types/PackageName/Magic.hs --- a/src/Distribution/Types/PackageName/Magic.hs +++ b/src/Distribution/Types/PackageName/Magic.hs @@ -11,9 +11,13 @@ nonExistentPackageThisIsCabalBug :: PackageName nonExistentPackageThisIsCabalBug = mkPackageName "nonexistent-package-this-is-a-cabal-bug" --- | Used by @cabal new-repl@ and @cabal new-run@ +-- | Used by @cabal new-repl@, @cabal new-run@ and @cabal new-build@ fakePackageName :: PackageName fakePackageName = mkPackageName "fake-package" + +-- | Used by @cabal new-run@ and @cabal new-build@ +fakePackageCabalFileName :: FilePath +fakePackageCabalFileName = "fake-package.cabal" -- | 'fakePackageName' with 'version0'. fakePackageId :: PackageId diff --git a/src/Distribution/Types/PackageVersionConstraint.hs b/src/Distribution/Types/PackageVersionConstraint.hs deleted file mode 100644 --- a/src/Distribution/Types/PackageVersionConstraint.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PackageVersionConstraint ( - PackageVersionConstraint(..), - thisPackageVersionConstraint, - simplifyPackageVersionConstraint, -) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageId -import Distribution.Types.PackageName -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal -import Distribution.Version (simplifyVersionRange) - -import qualified Distribution.Compat.CharParsing as P - --- | A version constraint on a package. Different from 'ExeDependency' and --- 'Dependency' since it does not specify the need for a component, not even --- the main library. --- There are a few places in the codebase where 'Dependency' was used where --- 'PackageVersionConstraint' is not used instead (#5570). -data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PackageVersionConstraint -instance Structured PackageVersionConstraint -instance NFData PackageVersionConstraint where rnf = genericRnf - -instance Pretty PackageVersionConstraint where - -- Cannot do: PackageVersionConstraint have to be parseable - -- as Dependency, due roundtrip problems. (e.g. talking to old ./Setup). - -- - -- pretty (PackageVersionConstraint name (ThisVersion ver)) = - -- pretty (PackageIdentifier name ver) - pretty (PackageVersionConstraint name ver) = - pretty name <+> pretty ver - --- | --- --- >>> simpleParsec "foo" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [0]))) --- --- >>> simpleParsec "foo >=2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (OrLaterVersion (mkVersion [2,0]))) --- --- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint --- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) --- -instance Parsec PackageVersionConstraint where - parsec = do - PackageIdentifier name ver <- parsec - if ver == nullVersion - then do - P.spaces - vr <- parsec <|> return anyVersion - P.spaces - return (PackageVersionConstraint name vr) - else - pure (PackageVersionConstraint name (thisVersion ver)) - --- | @since 3.4.0.0 -thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint -thisPackageVersionConstraint (PackageIdentifier pn vr) = - PackageVersionConstraint pn (thisVersion vr) - --- | @since 3.4.0.0 -simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint -simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) = - PackageVersionConstraint pn (simplifyVersionRange vr) diff --git a/src/Distribution/Types/ParStrat.hs b/src/Distribution/Types/ParStrat.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Types/ParStrat.hs @@ -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 diff --git a/src/Distribution/Types/PkgconfigDependency.hs b/src/Distribution/Types/PkgconfigDependency.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigDependency.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigDependency - ( PkgconfigDependency(..) - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.PkgconfigName -import Distribution.Types.PkgconfigVersionRange - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P - --- | Describes a dependency on a pkg-config library --- --- @since 2.0.0.2 -data PkgconfigDependency = PkgconfigDependency - PkgconfigName - PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigDependency -instance Structured PkgconfigDependency -instance NFData PkgconfigDependency where rnf = genericRnf - -instance Pretty PkgconfigDependency where - pretty (PkgconfigDependency name PcAnyVersion) = pretty name - pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver - -instance Parsec PkgconfigDependency where - parsec = do - name <- parsec - P.spaces - verRange <- parsec <|> pure anyPkgconfigVersion - pure $ PkgconfigDependency name verRange diff --git a/src/Distribution/Types/PkgconfigName.hs b/src/Distribution/Types/PkgconfigName.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigName.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigName - ( PkgconfigName, unPkgconfigName, mkPkgconfigName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- | A pkg-config library name --- --- This is parsed as any valid argument to the pkg-config utility. --- --- @since 2.0.0.2 -newtype PkgconfigName = PkgconfigName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data) - --- | Convert 'PkgconfigName' to 'String' --- --- @since 2.0.0.2 -unPkgconfigName :: PkgconfigName -> String -unPkgconfigName (PkgconfigName s) = fromShortText s - --- | Construct a 'PkgconfigName' from a 'String' --- --- 'mkPkgconfigName' is the inverse to 'unPkgconfigName' --- --- Note: No validations are performed to ensure that the resulting --- 'PkgconfigName' is valid --- --- @since 2.0.0.2 -mkPkgconfigName :: String -> PkgconfigName -mkPkgconfigName = PkgconfigName . toShortText - --- | 'mkPkgconfigName' --- --- @since 2.0.0.2 -instance IsString PkgconfigName where - fromString = mkPkgconfigName - -instance Binary PkgconfigName -instance Structured PkgconfigName - --- pkg-config allows versions and other letters in package names, eg --- "gtk+-2.0" is a valid pkg-config package _name_. It then has a package --- version number like 2.10.13 -instance Pretty PkgconfigName where - pretty = Disp.text . unPkgconfigName - -instance Parsec PkgconfigName where - parsec = mkPkgconfigName <$> P.munch1 isNameChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isNameChar '-' = True - isNameChar '_' = True - isNameChar '.' = True - isNameChar '+' = True - isNameChar c = isAlphaNum c - -instance NFData PkgconfigName where - rnf (PkgconfigName pkg) = rnf pkg diff --git a/src/Distribution/Types/PkgconfigVersion.hs b/src/Distribution/Types/PkgconfigVersion.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigVersion.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} --- @since 3.0 -module Distribution.Types.PkgconfigVersion ( - PkgconfigVersion (..), - rpmvercmp, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (isAsciiAlphaNum) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @pkg-config@ versions. --- --- In fact, this can be arbitrary 'BS.ByteString', --- but 'Parsec' instance is a little pickier. --- --- @since 3.0 -newtype PkgconfigVersion = PkgconfigVersion BS.ByteString - deriving (Generic, Read, Show, Typeable, Data) - -instance Eq PkgconfigVersion where - PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ - -instance Ord PkgconfigVersion where - PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b - -instance Binary PkgconfigVersion -instance Structured PkgconfigVersion -instance NFData PkgconfigVersion where rnf = genericRnf - -instance Pretty PkgconfigVersion where - pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs) - --- | --- --- >>> simpleParsec "1.0.2n" :: Maybe PkgconfigVersion --- Just (PkgconfigVersion "1.0.2n") --- --- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion --- Nothing --- -instance Parsec PkgconfigVersion where - parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where - predicate c = isAsciiAlphaNum c || c == '.' || c == '-' - -------------------------------------------------------------------------------- --- rmpvercmp - pure Haskell implementation -------------------------------------------------------------------------------- - --- | Compare two version strings as @pkg-config@ would compare them. --- --- @since 3.0 -rpmvercmp :: BS.ByteString -> BS.ByteString -> Ordering -rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b) - where - go0 :: [Word8] -> [Word8] -> Ordering - -- if there is _any_ trailing "garbage", it seems to affect result - -- https://github.com/haskell/cabal/issues/6805 - go0 [] [] = EQ - go0 [] _ = LT - go0 _ [] = GT - go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys) - - go1 :: [Word8] -> [Word8] -> Ordering - go1 [] [] = EQ - go1 [] _ = LT - go1 _ [] = GT - go1 xs@(x:_) ys - | isDigit8 x = - let (xs1, xs2) = span isDigit8 xs - (ys1, ys2) = span isDigit8 ys - -- numeric segments are always newer than alpha segments - in if null ys1 - then GT - else compareInt xs1 ys1 <> go0 xs2 ys2 - - -- isAlpha - | otherwise = - let (xs1, xs2) = span isAlpha8 xs - (ys1, ys2) = span isAlpha8 ys - in if null ys1 - then LT - else compareStr xs1 ys1 <> go0 xs2 ys2 - --- compare as numbers -compareInt :: [Word8] -> [Word8] -> Ordering -compareInt xs ys = - -- whichever number has more digits wins - compare (length xs') (length ys') <> - -- equal length: use per character compare, "strcmp" - compare xs' ys' - where - -- drop leading zeros - xs' = dropWhile (== 0x30) xs - ys' = dropWhile (== 0x30) ys - --- strcmp -compareStr :: [Word8] -> [Word8] -> Ordering -compareStr = compare - -dropNonAlnum8 :: [Word8] -> [Word8] -dropNonAlnum8 = dropWhile (\w -> not (isDigit8 w || isAlpha8 w)) - -isDigit8 :: Word8 -> Bool -isDigit8 w = 0x30 <= w && w <= 0x39 - -isAlpha8 :: Word8 -> Bool -isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A) - - diff --git a/src/Distribution/Types/PkgconfigVersionRange.hs b/src/Distribution/Types/PkgconfigVersionRange.hs deleted file mode 100644 --- a/src/Distribution/Types/PkgconfigVersionRange.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.PkgconfigVersionRange ( - PkgconfigVersionRange (..), - anyPkgconfigVersion, - isAnyPkgconfigVersion, - withinPkgconfigVersionRange, - -- * Internal - versionToPkgconfigVersion, - versionRangeToPkgconfigVersionRange, - ) where - -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PkgconfigVersion -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange - -import qualified Data.ByteString.Char8 as BS8 -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as PP - --- | @since 3.0 -data PkgconfigVersionRange - = PcAnyVersion - | PcThisVersion PkgconfigVersion -- = version - | PcLaterVersion PkgconfigVersion -- > version (NB. not >=) - | PcEarlierVersion PkgconfigVersion -- < version - | PcOrLaterVersion PkgconfigVersion -- >= version - | PcOrEarlierVersion PkgconfigVersion -- =< version - | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange - | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange - deriving (Generic, Read, Show, Eq, Typeable, Data) - -instance Binary PkgconfigVersionRange -instance Structured PkgconfigVersionRange -instance NFData PkgconfigVersionRange where rnf = genericRnf - -instance Pretty PkgconfigVersionRange where - pretty = pp 0 where - pp :: Int -> PkgconfigVersionRange -> PP.Doc - pp _ PcAnyVersion = PP.text "-any" - pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v - pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v - pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v - pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v - pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v - - pp d (PcUnionVersionRanges v u) = parens (d >= 1) $ - pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u - pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $ - pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u - - parens True = PP.parens - parens False = id - -instance Parsec PkgconfigVersionRange where - -- note: the wildcard is used in some places, e.g - -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal - -- - -- however, in the presence of alphanumerics etc. lax version parser, - -- wildcard is ill-specified - - parsec = do - csv <- askCabalSpecVersion - if csv >= CabalSpecV3_0 - then pkgconfigParser - else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv - --- "modern" parser of @pkg-config@ package versions. -pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange -pkgconfigParser = P.spaces >> expr where - -- every parser here eats trailing space - expr = do - ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces) - return $ foldr1 PcUnionVersionRanges ts - - term = do - fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces) - return $ foldr1 PcIntersectVersionRanges fs - - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces) - - "==" -> afterOp PcThisVersion - ">" -> afterOp PcLaterVersion - "<" -> afterOp PcEarlierVersion - ">=" -> afterOp PcOrLaterVersion - "<=" -> afterOp PcOrEarlierVersion - - _ -> P.unexpected $ "Unknown version operator " ++ show op - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = True - isOpChar _ = False - - afterOp f = do - P.spaces - v <- parsec - P.spaces - return (f v) - - parens = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - -anyPkgconfigVersion :: PkgconfigVersionRange -anyPkgconfigVersion = PcAnyVersion - --- | TODO: this is not precise, but used only to prettify output. -isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool -isAnyPkgconfigVersion = (== PcAnyVersion) - -withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool -withinPkgconfigVersionRange v = go where - go PcAnyVersion = True - go (PcThisVersion u) = v == u - go (PcLaterVersion u) = v > u - go (PcEarlierVersion u) = v < u - go (PcOrLaterVersion u) = v >= u - go (PcOrEarlierVersion u) = v <= u - go (PcUnionVersionRanges a b) = go a || go b - go (PcIntersectVersionRanges a b) = go a && go b - -------------------------------------------------------------------------------- --- Conversion -------------------------------------------------------------------------------- - -versionToPkgconfigVersion :: Version -> PkgconfigVersion -versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow - -versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange -versionRangeToPkgconfigVersionRange vr - | isAnyVersion vr - = PcAnyVersion - | otherwise - = case asVersionIntervals vr of - [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0")) - (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is - where - conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b - conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c) - - convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v) - convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v) - - convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v) - convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v) diff --git a/src/Distribution/Types/SetupBuildInfo.hs b/src/Distribution/Types/SetupBuildInfo.hs deleted file mode 100644 --- a/src/Distribution/Types/SetupBuildInfo.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SetupBuildInfo ( - SetupBuildInfo(..) -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.Dependency - --- --------------------------------------------------------------------------- --- The SetupBuildInfo type - --- One can see this as a very cut-down version of BuildInfo below. --- To keep things simple for tools that compile Setup.hs we limit the --- options authors can specify to just Haskell package dependencies. - -data SetupBuildInfo = SetupBuildInfo - { setupDepends :: [Dependency] - , defaultSetupDepends :: Bool - -- ^ Is this a default 'custom-setup' section added by the cabal-install - -- code (as opposed to user-provided)? This field is only used - -- internally, and doesn't correspond to anything in the .cabal - -- file. See #3199. - } - deriving (Generic, Show, Eq, Read, Typeable, Data) - -instance Binary SetupBuildInfo -instance Structured SetupBuildInfo -instance NFData SetupBuildInfo where rnf = genericRnf - -instance Monoid SetupBuildInfo where - mempty = SetupBuildInfo [] False - mappend = (<>) - -instance Semigroup SetupBuildInfo where - a <> b = SetupBuildInfo - (setupDepends a <> setupDepends b) - (defaultSetupDepends a || defaultSetupDepends b) diff --git a/src/Distribution/Types/SetupBuildInfo/Lens.hs b/src/Distribution/Types/SetupBuildInfo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/SetupBuildInfo/Lens.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Distribution.Types.SetupBuildInfo.Lens ( - SetupBuildInfo, - module Distribution.Types.SetupBuildInfo.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Dependency (Dependency) -import Distribution.Types.SetupBuildInfo (SetupBuildInfo) - -import qualified Distribution.Types.SetupBuildInfo as T - -setupDepends :: Lens' SetupBuildInfo [Dependency] -setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s)) -{-# INLINE setupDepends #-} - -defaultSetupDepends :: Lens' SetupBuildInfo Bool -defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s)) -{-# INLINE defaultSetupDepends #-} diff --git a/src/Distribution/Types/SourceRepo.hs b/src/Distribution/Types/SourceRepo.hs deleted file mode 100644 --- a/src/Distribution/Types/SourceRepo.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.SourceRepo ( - SourceRepo(..), - RepoKind(..), - RepoType(..), - KnownRepoType (..), - knownRepoTypes, - emptySourceRepo, - classifyRepoType, - classifyRepoKind, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.Generic (lowercase) - -import Distribution.Pretty -import Distribution.Parsec - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Data.Map.Strict as M - --- ------------------------------------------------------------ --- * Source repos --- ------------------------------------------------------------ - --- | Information about the source revision control system for a package. --- --- When specifying a repo it is useful to know the meaning or intention of the --- information as doing so enables automation. There are two obvious common --- purposes: one is to find the repo for the latest development version, the --- other is to find the repo for this specific release. The 'ReopKind' --- specifies which one we mean (or another custom one). --- --- A package can specify one or the other kind or both. Most will specify just --- a head repo but some may want to specify a repo to reconstruct the sources --- for this package release. --- --- The required information is the 'RepoType' which tells us if it's using --- 'Darcs', 'Git' for example. The 'repoLocation' and other details are --- interpreted according to the repo type. --- -data SourceRepo = SourceRepo { - -- | The kind of repo. This field is required. - repoKind :: RepoKind, - - -- | The type of the source repository system for this repo, eg 'Darcs' or - -- 'Git'. This field is required. - repoType :: Maybe RepoType, - - -- | The location of the repository. For most 'RepoType's this is a URL. - -- This field is required. - repoLocation :: Maybe String, - - -- | 'CVS' can put multiple \"modules\" on one server and requires a - -- module name in addition to the location to identify a particular repo. - -- Logically this is part of the location but unfortunately has to be - -- specified separately. This field is required for the 'CVS' 'RepoType' and - -- should not be given otherwise. - repoModule :: Maybe String, - - -- | The name or identifier of the branch, if any. Many source control - -- systems have the notion of multiple branches in a repo that exist in the - -- same location. For example 'Git' and 'CVS' use this while systems like - -- 'Darcs' use different locations for different branches. This field is - -- optional but should be used if necessary to identify the sources, - -- especially for the 'RepoThis' repo kind. - repoBranch :: Maybe String, - - -- | The tag identify a particular state of the repository. This should be - -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. - -- - repoTag :: Maybe String, - - -- | Some repositories contain multiple projects in different subdirectories - -- This field specifies the subdirectory where this packages sources can be - -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted - -- relative to the root of the repository. This field is optional. If not - -- given the default is \".\" ie no subdirectory. - repoSubdir :: Maybe FilePath -} - deriving (Eq, Ord, Generic, Read, Show, Typeable, Data) - -emptySourceRepo :: RepoKind -> SourceRepo -emptySourceRepo kind = SourceRepo - { repoKind = kind - , repoType = Nothing - , repoLocation = Nothing - , repoModule = Nothing - , repoBranch = Nothing - , repoTag = Nothing - , repoSubdir = Nothing - } - -instance Binary SourceRepo -instance Structured SourceRepo -instance NFData SourceRepo where rnf = genericRnf - --- | What this repo info is for, what it represents. --- -data RepoKind = - -- | The repository for the \"head\" or development version of the project. - -- This repo is where we should track the latest development activity or - -- the usual repo people should get to contribute patches. - RepoHead - - -- | The repository containing the sources for this exact package version - -- or release. For this kind of repo a tag should be given to give enough - -- information to re-create the exact sources. - | RepoThis - - | RepoKindUnknown String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoKind -instance Structured RepoKind -instance NFData RepoKind where rnf = genericRnf - --- | An enumeration of common source control systems. The fields used in the --- 'SourceRepo' depend on the type of repo. The tools and methods used to --- obtain and track the repo depend on the repo type. --- -data KnownRepoType = Darcs | Git | SVN | CVS - | Mercurial | GnuArch | Bazaar | Monotone - | Pijul -- ^ @since 3.4.0.0 - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded) - -instance Binary KnownRepoType -instance Structured KnownRepoType -instance NFData KnownRepoType where rnf = genericRnf - -instance Parsec KnownRepoType where - parsec = do - str <- P.munch1 isIdent - maybe - (P.unexpected $ "Could not parse KnownRepoType from " ++ str) - return - (M.lookup str knownRepoTypeMap) - -instance Pretty KnownRepoType where - pretty = Disp.text . lowercase . show - -data RepoType = KnownRepoType KnownRepoType - | OtherRepoType String - deriving (Eq, Generic, Ord, Read, Show, Typeable, Data) - -instance Binary RepoType -instance Structured RepoType -instance NFData RepoType where rnf = genericRnf - -knownRepoTypes :: [KnownRepoType] -knownRepoTypes = [minBound .. maxBound] - -repoTypeAliases :: KnownRepoType -> [String] -repoTypeAliases Bazaar = ["bzr"] -repoTypeAliases Mercurial = ["hg"] -repoTypeAliases GnuArch = ["arch"] -repoTypeAliases _ = [] - -instance Pretty RepoKind where - pretty RepoHead = Disp.text "head" - pretty RepoThis = Disp.text "this" - pretty (RepoKindUnknown other) = Disp.text other - -instance Parsec RepoKind where - parsec = classifyRepoKind <$> P.munch1 isIdent - -classifyRepoKind :: String -> RepoKind -classifyRepoKind name = case lowercase name of - "head" -> RepoHead - "this" -> RepoThis - _ -> RepoKindUnknown name - -instance Parsec RepoType where - parsec = classifyRepoType <$> P.munch1 isIdent - -instance Pretty RepoType where - pretty (OtherRepoType other) = Disp.text other - pretty (KnownRepoType t) = pretty t - -classifyRepoType :: String -> RepoType -classifyRepoType s = - maybe - (OtherRepoType s) - KnownRepoType - (M.lookup (lowercase s) knownRepoTypeMap) - -knownRepoTypeMap :: Map String KnownRepoType -knownRepoTypeMap = - M.fromList - [ (name, repoType') - | repoType' <- knownRepoTypes - , name <- prettyShow repoType' : repoTypeAliases repoType' - ] - -isIdent :: Char -> Bool -isIdent c = isAlphaNum c || c == '_' || c == '-' diff --git a/src/Distribution/Types/SourceRepo/Lens.hs b/src/Distribution/Types/SourceRepo/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/SourceRepo/Lens.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Distribution.Types.SourceRepo.Lens ( - T.SourceRepo, - module Distribution.Types.SourceRepo.Lens, - ) where - -import Prelude() -import Distribution.Compat.Prelude -import Distribution.Compat.Lens - -import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType) -import qualified Distribution.Types.SourceRepo as T - -repoKind :: Lens' SourceRepo RepoKind -repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s)) -{-# INLINE repoKind #-} - -repoType :: Lens' SourceRepo (Maybe RepoType) -repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s)) -{-# INLINE repoType #-} - -repoLocation :: Lens' SourceRepo (Maybe String) -repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s)) -{-# INLINE repoLocation #-} - -repoModule :: Lens' SourceRepo (Maybe String) -repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s)) -{-# INLINE repoModule #-} - -repoBranch :: Lens' SourceRepo (Maybe String) -repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s)) -{-# INLINE repoBranch #-} - -repoTag :: Lens' SourceRepo (Maybe String) -repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s)) -{-# INLINE repoTag #-} - -repoSubdir :: Lens' SourceRepo (Maybe FilePath) -repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s)) -{-# INLINE repoSubdir #-} diff --git a/src/Distribution/Types/TargetInfo.hs b/src/Distribution/Types/TargetInfo.hs --- a/src/Distribution/Types/TargetInfo.hs +++ b/src/Distribution/Types/TargetInfo.hs @@ -1,33 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -module Distribution.Types.TargetInfo ( - TargetInfo(..) -) where -import Prelude () +module Distribution.Types.TargetInfo + ( TargetInfo (..) + ) where + import Distribution.Compat.Prelude +import Prelude () -import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.Component +import Distribution.Types.ComponentLocalBuildInfo import Distribution.Types.UnitId -import Distribution.Compat.Graph (IsNode(..)) +import Distribution.Compat.Graph (IsNode (..)) -- | The 'TargetInfo' contains all the information necessary to build a -- specific target (e.g., component/module/file) in a package. In -- principle, one can get the 'Component' from a -- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more -- convenient to have the component in hand. -data TargetInfo = TargetInfo { - targetCLBI :: ComponentLocalBuildInfo, - targetComponent :: Component - -- TODO: BuildTargets supporting parsing these is dumb, - -- we don't have support for compiling single modules or - -- file paths. Accommodating it now is premature - -- generalization. Figure it out later. - -- targetSub :: Maybe (Either ModuleName FilePath) - } +data TargetInfo = TargetInfo + { targetCLBI :: ComponentLocalBuildInfo + , targetComponent :: Component + -- TODO: BuildTargets supporting parsing these is dumb, + -- we don't have support for compiling single modules or + -- file paths. Accommodating it now is premature + -- generalization. Figure it out later. + -- targetSub :: Maybe (Either ModuleName FilePath) + } + deriving (Generic, Show) +instance Binary TargetInfo +instance Structured TargetInfo + instance IsNode TargetInfo where - type Key TargetInfo = UnitId - nodeKey = nodeKey . targetCLBI - nodeNeighbors = nodeNeighbors . targetCLBI + type Key TargetInfo = UnitId + nodeKey = nodeKey . targetCLBI + nodeNeighbors = nodeNeighbors . targetCLBI diff --git a/src/Distribution/Types/TestSuite.hs b/src/Distribution/Types/TestSuite.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuite.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.TestSuite ( - TestSuite(..), - emptyTestSuite, - testType, - testModules, - testModulesAutogen -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.BuildInfo -import Distribution.Types.TestType -import Distribution.Types.TestSuiteInterface -import Distribution.Types.UnqualComponentName - -import Distribution.ModuleName - -import qualified Distribution.Types.BuildInfo.Lens as L - --- | A \"test-suite\" stanza in a cabal file. --- -data TestSuite = TestSuite { - testName :: UnqualComponentName, - testInterface :: TestSuiteInterface, - testBuildInfo :: BuildInfo - } - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance L.HasBuildInfo TestSuite where - buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) - -instance Binary TestSuite -instance Structured TestSuite - -instance NFData TestSuite where rnf = genericRnf - -instance Monoid TestSuite where - mempty = TestSuite { - testName = mempty, - testInterface = mempty, - testBuildInfo = mempty - } - mappend = (<>) - -instance Semigroup TestSuite where - a <> b = TestSuite { - testName = combine' testName, - testInterface = combine testInterface, - testBuildInfo = combine testBuildInfo - } - where combine field = field a `mappend` field b - combine' field = case ( unUnqualComponentName $ field a - , unUnqualComponentName $ field b) of - ("", _) -> field b - (_, "") -> field a - (x, y) -> error $ "Ambiguous values for test field: '" - ++ x ++ "' and '" ++ y ++ "'" - -emptyTestSuite :: TestSuite -emptyTestSuite = mempty - - -testType :: TestSuite -> TestType -testType test = case testInterface test of - TestSuiteExeV10 ver _ -> TestTypeExe ver - TestSuiteLibV09 ver _ -> TestTypeLib ver - TestSuiteUnsupported testtype -> testtype - --- | Get all the module names from a test suite. -testModules :: TestSuite -> [ModuleName] -testModules test = (case testInterface test of - TestSuiteLibV09 _ m -> [m] - _ -> []) - ++ otherModules (testBuildInfo test) - --- | Get all the auto generated module names from a test suite. --- This are a subset of 'testModules'. -testModulesAutogen :: TestSuite -> [ModuleName] -testModulesAutogen test = autogenModules (testBuildInfo test) diff --git a/src/Distribution/Types/TestSuite/Lens.hs b/src/Distribution/Types/TestSuite/Lens.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuite/Lens.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Distribution.Types.TestSuite.Lens ( - TestSuite, - module Distribution.Types.TestSuite.Lens, - ) where - -import Distribution.Compat.Lens -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.TestSuite (TestSuite) -import Distribution.Types.TestSuiteInterface (TestSuiteInterface) -import Distribution.Types.UnqualComponentName (UnqualComponentName) - -import qualified Distribution.Types.TestSuite as T - -testName :: Lens' TestSuite UnqualComponentName -testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) -{-# INLINE testName #-} - -testInterface :: Lens' TestSuite TestSuiteInterface -testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) -{-# INLINE testInterface #-} - -testBuildInfo :: Lens' TestSuite BuildInfo -testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s)) -{-# INLINE testBuildInfo #-} diff --git a/src/Distribution/Types/TestSuiteInterface.hs b/src/Distribution/Types/TestSuiteInterface.hs deleted file mode 100644 --- a/src/Distribution/Types/TestSuiteInterface.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - -module Distribution.Types.TestSuiteInterface ( - TestSuiteInterface(..), -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Types.TestType -import Distribution.ModuleName -import Distribution.Version - --- | The test suite interfaces that are currently defined. Each test suite must --- specify which interface it supports. --- --- More interfaces may be defined in future, either new revisions or totally --- new interfaces. --- -data TestSuiteInterface = - - -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form - -- of an executable. It returns a zero exit code for success, non-zero for - -- failure. The stdout and stderr channels may be logged. It takes no - -- command line parameters and nothing on stdin. - -- - TestSuiteExeV10 Version FilePath - - -- | Test interface \"detailed-0.9\". The test-suite takes the form of a - -- library containing a designated module that exports \"tests :: [Test]\". - -- - | TestSuiteLibV09 Version ModuleName - - -- | A test suite that does not conform to one of the above interfaces for - -- the given reason (e.g. unknown test type). - -- - | TestSuiteUnsupported TestType - deriving (Eq, Generic, Read, Show, Typeable, Data) - -instance Binary TestSuiteInterface -instance Structured TestSuiteInterface - -instance NFData TestSuiteInterface where rnf = genericRnf - -instance Monoid TestSuiteInterface where - mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion) - mappend = (<>) - -instance Semigroup TestSuiteInterface where - a <> (TestSuiteUnsupported _) = a - _ <> b = b diff --git a/src/Distribution/Types/TestType.hs b/src/Distribution/Types/TestType.hs deleted file mode 100644 --- a/src/Distribution/Types/TestType.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module Distribution.Types.TestType ( - TestType(..), - knownTestTypes, -) where - -import Distribution.Compat.Prelude -import Distribution.Version -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Text.PrettyPrint (char, text) - --- | The \"test-type\" field in the test suite stanza. --- -data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" - | TestTypeLib Version -- ^ \"type: detailed-x.y\" - | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary TestType -instance Structured TestType - -instance NFData TestType where rnf = genericRnf - -knownTestTypes :: [TestType] -knownTestTypes = [ TestTypeExe (mkVersion [1,0]) - , TestTypeLib (mkVersion [0,9]) ] - -instance Pretty TestType where - pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver - pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver - pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver - -instance Parsec TestType where - parsec = parsecStandard $ \ver name -> case name of - "exitcode-stdio" -> TestTypeExe ver - "detailed" -> TestTypeLib ver - _ -> TestTypeUnknown name ver diff --git a/src/Distribution/Types/UnitId.hs b/src/Distribution/Types/UnitId.hs deleted file mode 100644 --- a/src/Distribution/Types/UnitId.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleContexts #-} - -module Distribution.Types.UnitId - ( UnitId, unUnitId, mkUnitId - , DefUnitId - , unsafeMkDefUnitId - , unDefUnitId - , newSimpleUnitId - , mkLegacyUnitId - , getHSLibraryName - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText - -import qualified Distribution.Compat.CharParsing as P -import Distribution.Pretty -import Distribution.Parsec -import Distribution.Types.ComponentId -import Distribution.Types.PackageId - -import Text.PrettyPrint (text) - --- | A unit identifier identifies a (possibly instantiated) --- package/component that can be installed the installed package --- database. There are several types of components that can be --- installed: --- --- * A traditional library with no holes, so that 'unitIdHash' --- is @Nothing@. In the absence of Backpack, 'UnitId' --- is the same as a 'ComponentId'. --- --- * An indefinite, Backpack library with holes. In this case, --- 'unitIdHash' is still @Nothing@, but in the install, --- there are only interfaces, no compiled objects. --- --- * An instantiated Backpack library with all the holes --- filled in. 'unitIdHash' is a @Just@ a hash of the --- instantiating mapping. --- --- A unit is a component plus the additional information on how the --- holes are filled in. Thus there is a one to many relationship: for a --- particular component there are many different ways of filling in the --- holes, and each different combination is a unit (and has a separate --- 'UnitId'). --- --- 'UnitId' is distinct from 'OpenUnitId', in that it is always --- installed, whereas 'OpenUnitId' are intermediate unit identities --- that arise during mixin linking, and don't necessarily correspond --- to any actually installed unit. Since the mapping is not actually --- recorded in a 'UnitId', you can't actually substitute over them --- (but you can substitute over 'OpenUnitId'). See also --- "Distribution.Backpack.FullUnitId" for a mechanism for expanding an --- instantiated 'UnitId' to retrieve its mapping. --- --- Backwards compatibility note: if you need to get the string --- representation of a UnitId to pass, e.g., as a @-package-id@ --- flag, use the 'display' function, which will work on all --- versions of Cabal. --- -newtype UnitId = UnitId ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData) - -instance Binary UnitId -instance Structured UnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Pretty UnitId where - pretty = text . unUnitId - --- | The textual format for 'UnitId' coincides with the format --- GHC accepts for @-package-id@. --- -instance Parsec UnitId where - parsec = mkUnitId <$> P.munch1 isUnitChar where - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isUnitChar '-' = True - isUnitChar '_' = True - isUnitChar '.' = True - isUnitChar '+' = True - isUnitChar c = isAlphaNum c - --- | If you need backwards compatibility, consider using 'display' --- instead, which is supported by all versions of Cabal. --- -unUnitId :: UnitId -> String -unUnitId (UnitId s) = fromShortText s - -mkUnitId :: String -> UnitId -mkUnitId = UnitId . toShortText - --- | 'mkUnitId' --- --- @since 2.0.0.2 -instance IsString UnitId where - fromString = mkUnitId - --- | Create a unit identity with no associated hash directly --- from a 'ComponentId'. -newSimpleUnitId :: ComponentId -> UnitId -newSimpleUnitId = mkUnitId . unComponentId - --- | Make an old-style UnitId from a package identifier. --- Assumed to be for the public library -mkLegacyUnitId :: PackageId -> UnitId -mkLegacyUnitId = newSimpleUnitId . mkComponentId . prettyShow - --- | Returns library name prefixed with HS, suitable for filenames -getHSLibraryName :: UnitId -> String -getHSLibraryName uid = "HS" ++ prettyShow uid - --- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says --- that a 'UnitId' identified this way is definite; i.e., it has no --- unfilled holes. -newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId } - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty) - -instance Structured DefUnitId - --- Workaround for a GHC 8.0.1 bug, see --- https://github.com/haskell/cabal/issues/4793#issuecomment-334258288 -instance Parsec DefUnitId where - parsec = DefUnitId <$> parsec - --- | Unsafely create a 'DefUnitId' from a 'UnitId'. Your responsibility --- is to ensure that the 'DefUnitId' invariant holds. -unsafeMkDefUnitId :: UnitId -> DefUnitId -unsafeMkDefUnitId = DefUnitId diff --git a/src/Distribution/Types/UnqualComponentName.hs b/src/Distribution/Types/UnqualComponentName.hs deleted file mode 100644 --- a/src/Distribution/Types/UnqualComponentName.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Distribution.Types.UnqualComponentName - ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName - , packageNameToUnqualComponentName, unqualComponentNameToPackageName - ) where - -import Distribution.Compat.Prelude -import Distribution.Utils.ShortText -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Types.PackageName - --- | An unqualified component name, for any kind of component. --- --- This is distinguished from a 'ComponentName' and 'ComponentId'. The former --- also states which of a library, executable, etc the name refers too. The --- later uniquely identifiers a component and its closure. --- --- @since 2.0.0.2 -newtype UnqualComponentName = UnqualComponentName ShortText - deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, - Semigroup, Monoid) -- TODO: bad enabler of bad monoids - --- | Convert 'UnqualComponentName' to 'String' --- --- @since 2.0.0.2 -unUnqualComponentName :: UnqualComponentName -> String -unUnqualComponentName (UnqualComponentName s) = fromShortText s - --- | @since 3.4.0.0 -unUnqualComponentNameST :: UnqualComponentName -> ShortText -unUnqualComponentNameST (UnqualComponentName s) = s - --- | Construct a 'UnqualComponentName' from a 'String' --- --- 'mkUnqualComponentName' is the inverse to 'unUnqualComponentName' --- --- Note: No validations are performed to ensure that the resulting --- 'UnqualComponentName' is valid --- --- @since 2.0.0.2 -mkUnqualComponentName :: String -> UnqualComponentName -mkUnqualComponentName = UnqualComponentName . toShortText - --- | 'mkUnqualComponentName' --- --- @since 2.0.0.2 -instance IsString UnqualComponentName where - fromString = mkUnqualComponentName - -instance Binary UnqualComponentName -instance Structured UnqualComponentName - -instance Pretty UnqualComponentName where - pretty = showToken . unUnqualComponentName - -instance Parsec UnqualComponentName where - parsec = mkUnqualComponentName <$> parsecUnqualComponentName - -instance NFData UnqualComponentName where - rnf (UnqualComponentName pkg) = rnf pkg - --- TODO avoid String round trip with these PackageName <-> --- UnqualComponentName converters. - --- | Converts a package name to an unqualified component name --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- 2018-12-21: These "legacy" situations are not legacy. --- We can @build-depends@ on the internal library. However --- Now dependency contains @Set LibraryName@, and we should use that. --- --- @since 2.0.0.2 -packageNameToUnqualComponentName :: PackageName -> UnqualComponentName -packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST - --- | Converts an unqualified component name to a package name --- --- `packageNameToUnqualComponentName` is the inverse of --- `unqualComponentNameToPackageName`. --- --- Useful in legacy situations where a package name may refer to an internal --- component, if one is defined with that name. --- --- @since 2.0.0.2 -unqualComponentNameToPackageName :: UnqualComponentName -> PackageName -unqualComponentNameToPackageName = mkPackageNameST . unUnqualComponentNameST diff --git a/src/Distribution/Types/Version.hs b/src/Distribution/Types/Version.hs deleted file mode 100644 --- a/src/Distribution/Types/Version.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -module Distribution.Types.Version ( - -- * Package versions - Version, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - version0, - - -- * Internal - validVersion, - versionDigitParser, - ) where - -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Data.Version as Base -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import qualified Text.Read as Read - --- | A 'Version' represents the version of a software entity. --- --- Instances of 'Eq' and 'Ord' are provided, which gives exact --- equality and lexicographic ordering of the version number --- components (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2, etc.). --- --- This type is opaque and distinct from the 'Base.Version' type in --- "Data.Version" since @Cabal-2.0@. The difference extends to the --- 'Binary' instance using a different (and more compact) encoding. --- --- @since 2.0.0.2 -data Version = PV0 {-# UNPACK #-} !Word64 - | PV1 !Int [Int] - -- NOTE: If a version fits into the packed Word64 - -- representation (i.e. at most four version components - -- which all fall into the [0..0xfffe] range), then PV0 - -- MUST be used. This is essential for the 'Eq' instance - -- to work. - deriving (Data,Eq,Generic,Typeable) - -instance Ord Version where - compare (PV0 x) (PV0 y) = compare x y - compare (PV1 x xs) (PV1 y ys) = case compare x y of - EQ -> compare xs ys - c -> c - compare (PV0 w) (PV1 y ys) = case compare x y of - EQ -> compare [x2,x3,x4] ys - c -> c - where - x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - x4 = fromIntegral (w .&. 0xffff) - 1 - compare (PV1 x xs) (PV0 w) = case compare x y of - EQ -> compare xs [y2,y3,y4] - c -> c - where - y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - y4 = fromIntegral (w .&. 0xffff) - 1 - -instance Show Version where - showsPrec d v = showParen (d > 10) - $ showString "mkVersion " - . showsPrec 11 (versionNumbers v) - -instance Read Version where - readPrec = Read.parens $ do - Read.Ident "mkVersion" <- Read.lexP - v <- Read.step Read.readPrec - return (mkVersion v) - -instance Binary Version -instance Structured Version - -instance NFData Version where - rnf (PV0 _) = () - rnf (PV1 _ ns) = rnf ns - -instance Pretty Version where - pretty ver - = Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - -instance Parsec Version where - parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags - where - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - --- | An integral without leading zeroes. --- --- @since 3.0 -versionDigitParser :: CabalParsing m => m Int -versionDigitParser = (some d >>= toNumber) P. "version digit (integral without leading zeroes)" - where - toNumber :: CabalParsing m => [Int] -> m Int - toNumber [0] = return 0 - toNumber (0:_) = P.unexpected "Version digit with leading zero" - toNumber xs - -- 10^9 = 1000000000 - -- 2^30 = 1073741824 - -- - -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'. - | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part" - | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs - - d :: P.CharParsing m => m Int - d = f <$> P.satisfyRange '0' '9' - f c = ord c - ord '0' - --- | Construct 'Version' from list of version number components. --- --- For instance, @mkVersion [3,2,1]@ constructs a 'Version' --- representing the version @3.2.1@. --- --- All version components must be non-negative. @mkVersion []@ --- currently represents the special /null/ version; see also 'nullVersion'. --- --- @since 2.0.0.2 -mkVersion :: [Int] -> Version --- TODO: add validity check; disallow 'mkVersion []' (we have --- 'nullVersion' for that) -mkVersion [] = nullVersion -mkVersion (v1:[]) - | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1) - | otherwise = PV1 v1 [] - where - inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1)) - mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0 - -mkVersion (v1:vs@(v2:[])) - | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2) - | otherwise = PV1 v1 vs - where - inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1)) - mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0 - -mkVersion (v1:vs@(v2:v3:[])) - | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3) - | otherwise = PV1 v1 vs - where - inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1)) - mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0 - -mkVersion (v1:vs@(v2:v3:v4:[])) - | inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4) - | otherwise = PV1 v1 vs - where - inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1) - .|. x2 .|. (x2+1) - .|. x3 .|. (x3+1) - .|. x4 .|. (x4+1)) - mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1) - -mkVersion (v1:vs) = PV1 v1 vs - --- | Version 0. A lower bound of 'Version'. --- --- @since 2.2 -version0 :: Version -version0 = mkVersion [0] - -{-# INLINE mkWord64VerRep #-} -mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64 -mkWord64VerRep v1 v2 v3 v4 = - (fromIntegral v1 `shiftL` 48) - .|. (fromIntegral v2 `shiftL` 32) - .|. (fromIntegral v3 `shiftL` 16) - .|. fromIntegral v4 - -{-# INLINE inWord16 #-} -inWord16 :: Int -> Bool -inWord16 x = (fromIntegral x :: Word) <= 0xffff - --- | Variant of 'mkVersion' which converts a "Data.Version" --- 'Base.Version' into Cabal's 'Version' type. --- --- @since 2.0.0.2 -mkVersion' :: Base.Version -> Version -mkVersion' = mkVersion . Base.versionBranch - --- | Unpack 'Version' into list of version number components. --- --- This is the inverse to 'mkVersion', so the following holds: --- --- > (versionNumbers . mkVersion) vs == vs --- --- @since 2.0.0.2 -versionNumbers :: Version -> [Int] -versionNumbers (PV1 n ns) = n:ns -versionNumbers (PV0 w) - | v1 < 0 = [] - | v2 < 0 = [v1] - | v3 < 0 = [v1,v2] - | v4 < 0 = [v1,v2,v3] - | otherwise = [v1,v2,v3,v4] - where - v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1 - v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1 - v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1 - v4 = fromIntegral (w .&. 0xffff) - 1 - - --- | Constant representing the special /null/ 'Version' --- --- The 'nullVersion' compares (via 'Ord') as less than every proper --- 'Version' value. --- --- @since 2.0.0.2 -nullVersion :: Version --- TODO: at some point, 'mkVersion' may disallow creating /null/ --- 'Version's -nullVersion = PV0 0 - --- | Apply function to list of version number components --- --- > alterVersion f == mkVersion . f . versionNumbers --- --- @since 2.0.0.2 -alterVersion :: ([Int] -> [Int]) -> Version -> Version -alterVersion f = mkVersion . f . versionNumbers - --- internal helper -validVersion :: Version -> Bool -validVersion v = v /= nullVersion && all (>=0) (versionNumbers v) diff --git a/src/Distribution/Types/VersionInterval.hs b/src/Distribution/Types/VersionInterval.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionInterval.hs +++ /dev/null @@ -1,345 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | In @Cabal-3.6@ this module have been rewritten. --- --- -module Distribution.Types.VersionInterval ( - -- * Version intervals - VersionIntervals, - unVersionIntervals, - - -- * Conversions - toVersionIntervals, - fromVersionIntervals, - - -- ** Normalisation - normaliseVersionRange2, - - -- * Relaxation - relaxLastInterval, - relaxHeadInterval, - - -- * Version intervals view - asVersionIntervals, - VersionInterval (..), - LowerBound(..), - UpperBound(..), - Bound(..), - - -- * Invariants - invariantVersionIntervals, - ) where - -import Control.Applicative (liftA2) -import Control.Exception (assert) -import Distribution.Compat.Prelude -import Prelude () - -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal - --- To test this module, and to run version range normalisation benchmarks: --- --- cabal run Cabal:unit-tests -- -p Distribution.Version --- cabal run cabal-benchmarks -- -o bench.html normaliseVersionRange - -------------------------------------------------------------------------------- --- Data -------------------------------------------------------------------------------- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show, Typeable) - --- | Inspect the list of version intervals. --- -unVersionIntervals :: VersionIntervals -> [VersionInterval] -unVersionIntervals (VersionIntervals is) = is - -data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show) -data LowerBound = LowerBound !Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -zeroLowerBound :: LowerBound -zeroLowerBound = LowerBound version0 InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (==) version0 - -------------------------------------------------------------------------------- --- Stage1 -------------------------------------------------------------------------------- - -stage1 :: VersionRange -> [VersionInterval] -stage1 = cataVersionRange alg where - -- version range leafs transform into singleton intervals - alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)] - alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound] - alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] - alg (EarlierVersionF v) - | isVersion0 v = [] - | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)] - alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)] - - -- ^>= version-range's upper bound should be MajorBound - alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)] - - -- union: just merge the version intervals - alg (UnionVersionRangesF v1 v2) = v1 ++ v2 - - -- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant. - alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2) - --- | Creck that interval is non-empty -nonEmptyInterval :: VersionInterval -> Maybe VersionInterval -nonEmptyInterval i | nonEmptyVI i = Just i -nonEmptyInterval _ = Nothing - -------------------------------------------------------------------------------- --- Stage2 -------------------------------------------------------------------------------- - -stage2 :: [VersionInterval] -> [VersionInterval] -stage2 = sortBy lowerboundCmp - -lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering -lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) = - compare v u `mappend` compareBound vb ub - where - compareBound :: Bound -> Bound -> Ordering - compareBound InclusiveBound InclusiveBound = EQ - compareBound InclusiveBound ExclusiveBound = LT - compareBound ExclusiveBound InclusiveBound = GT - compareBound ExclusiveBound ExclusiveBound = EQ - -------------------------------------------------------------------------------- --- Postprocess -------------------------------------------------------------------------------- - --- | Post-processing takes a list of ordered version intervals, --- but possibly overlapping, and creates 'VersionIntervals'. --- -postprocess :: [VersionInterval] -> VersionIntervals -postprocess = checkInvariant . VersionIntervals . stage2and3 - -stage2and3 :: [VersionInterval] -> [VersionInterval] -stage2and3 = stage3 . stage2 - -stage3 :: [VersionInterval] -> [VersionInterval] -stage3 [] = [] -stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest - -stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval] -stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound] -stage3go !lb !ub [] = [VersionInterval lb ub] -stage3go !lb !ub (VersionInterval lb' ub' : rest') - | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest' - | otherwise = stage3go lb (unionUpper ub ub') rest' - -------------------------------------------------------------------------------- --- Intersections -------------------------------------------------------------------------------- - -intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval -intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) = - VersionInterval (intersectLower lv lu) (intersectUpper uv uu) - -intersectLower :: LowerBound -> LowerBound -> LowerBound -intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of - EQ -> LowerBound v (intersectBound vb ub) - LT -> LowerBound u ub - GT -> LowerBound v vb - -intersectUpper :: UpperBound -> UpperBound -> UpperBound -intersectUpper NoUpperBound b = b -intersectUpper b NoUpperBound = b -intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (intersectBound vb ub) - LT -> UpperBound v vb - GT -> UpperBound u ub - -intersectBound :: Bound -> Bound -> Bound -intersectBound InclusiveBound InclusiveBound = InclusiveBound -intersectBound _ _ = ExclusiveBound - -------------------------------------------------------------------------------- --- Unions -------------------------------------------------------------------------------- - -unionUpper :: UpperBound -> UpperBound -> UpperBound -unionUpper NoUpperBound _ = NoUpperBound -unionUpper _ NoUpperBound = NoUpperBound -unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of - EQ -> UpperBound v (unionBound vb ub) - LT -> UpperBound u ub - GT -> UpperBound v vb - -unionBound :: Bound -> Bound -> Bound -unionBound ExclusiveBound ExclusiveBound = ExclusiveBound -unionBound _ _ = InclusiveBound - -------------------------------------------------------------------------------- --- VersionRange -------------------------------------------------------------------------------- - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = unVersionIntervals . toVersionIntervals - -------------------------------------------------------------------------------- --- Helpers -------------------------------------------------------------------------------- - --- | Check an upper bound does not intersect, or even touch a lower bound: --- --- @ --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- @ --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - -------------------------------------------------------------------------------- --- Invariants -------------------------------------------------------------------------------- - --- | 'VersionIntervals' invariant: --- --- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty) --- * intervals doesn't touch each other (distinct) --- -invariantVersionIntervals :: VersionIntervals -> Bool -invariantVersionIntervals (VersionIntervals intervals) = - all validInterval intervals && - all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariantVersionIntervals is) is -{-# INLINE checkInvariant #-} - -validInterval :: VersionInterval -> Bool -validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (VersionInterval _ NoUpperBound) = True -nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = postprocess . stage1 - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs)) - -intervalToVersionRange :: VersionInterval -> VersionRange -intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of - NoUpperBound - -> lowerBound - - UpperBound u ub - | vb == InclusiveBound - , ub == InclusiveBound - , v == u - -> thisVersion v - - UpperBound u ub -> withLowerBound (makeUpperBound u ub) - where - lowerBound :: VersionRange - lowerBound = case vb of - InclusiveBound -> orLaterVersion v - ExclusiveBound -> laterVersion v - - withLowerBound :: VersionRange -> VersionRange - withLowerBound vr - | isVersion0 v, vb == InclusiveBound = vr - | otherwise = intersectVersionRanges lowerBound vr - - makeUpperBound :: Version -> Bound -> VersionRange - makeUpperBound u InclusiveBound = orEarlierVersion u - makeUpperBound u ExclusiveBound = earlierVersion u - -------------------------------------------------------------------------------- --- Normalisation -------------------------------------------------------------------------------- - --- | Since @Cabal-3.6@ this function.. TODO --- -normaliseVersionRange2 :: VersionRange -> VersionRange -normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals - -------------------------------------------------------------------------------- --- Relaxation -------------------------------------------------------------------------------- - -relaxLastInterval :: VersionIntervals -> VersionIntervals -relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) - where - relaxLastInterval' [] = [] - relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - -relaxHeadInterval :: VersionIntervals -> VersionIntervals -relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) - where - relaxHeadInterval' [] = [] - relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is diff --git a/src/Distribution/Types/VersionInterval/Legacy.hs b/src/Distribution/Types/VersionInterval/Legacy.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionInterval/Legacy.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} --- | This is old version of "Distribution.Types.VersionInterval" module. --- --- It will be removed in @Cabal-3.8@. --- -module Distribution.Types.VersionInterval.Legacy {-# DEPRECATED "Use Distribution.Types.VersionInterval instead" #-} ( - -- * Version intervals - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - invertVersionIntervals, - relaxLastInterval, - relaxHeadInterval, - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - ) where - -import Prelude () -import Distribution.Compat.Prelude -import Control.Exception (assert) - -import Distribution.Types.Version -import Distribution.Types.VersionRange.Internal - --- NonEmpty -import qualified Prelude (foldr1) - -------------------------------------------------------------------------------- --- VersionRange -------------------------------------------------------------------------------- - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - - -------------------------------------------------------------------------------- --- VersionInterval -------------------------------------------------------------------------------- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show, Typeable) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (mkVersion [0]) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 = (==) version0 - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals = case intervals of - [] -> [] - (_:tl) -> zip intervals tl - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | Directly construct a 'VersionIntervals' from a list of intervals. --- --- In @Cabal-2.2@ the 'Maybe' is dropped from the result type. --- -mkVersionIntervals :: [VersionInterval] -> VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = VersionIntervals intervals - | otherwise - = checkInvariant - . foldl' (flip insertInterval) (VersionIntervals []) - . filter validInterval - $ intervals - -insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals -insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmptyVI :: VersionInterval -> Bool -nonEmptyVI (_, NoUpperBound ) = True -nonEmptyVI (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = cataVersionRange alg where - alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound) - alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound) - alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound) - alg (EarlierVersionF v) - | isVersion0 v = VersionIntervals [] - | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound) - alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound) - alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound) - alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2 - - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = thisVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = Nothing - | otherwise = Just (orLaterVersion v) - lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v) - - upperBound NoUpperBound = Nothing - upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v) - upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v) - - intersectVersionRanges' Nothing Nothing = anyVersion - intersectVersionRanges' (Just vr) Nothing = vr - intersectVersionRanges' Nothing (Just vr) = vr - intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -invertVersionIntervals :: VersionIntervals - -> VersionIntervals -invertVersionIntervals (VersionIntervals xs) = - case xs of - -- Empty interval set - [] -> VersionIntervals [(noLowerBound, NoUpperBound)] - -- Interval with no lower bound - ((lb, ub) : more) | lb == noLowerBound -> - VersionIntervals $ invertVersionIntervals' ub more - -- Interval with a lower bound - ((lb, ub) : more) -> - VersionIntervals $ (noLowerBound, invertLowerBound lb) - : invertVersionIntervals' ub more - where - -- Invert subsequent version intervals given the upper bound of - -- the intervals already inverted. - invertVersionIntervals' :: UpperBound - -> [(LowerBound, UpperBound)] - -> [(LowerBound, UpperBound)] - invertVersionIntervals' NoUpperBound [] = [] - invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)] - invertVersionIntervals' ub0 [(lb, NoUpperBound)] = - [(invertUpperBound ub0, invertLowerBound lb)] - invertVersionIntervals' ub0 ((lb, ub1) : more) = - (invertUpperBound ub0, invertLowerBound lb) - : invertVersionIntervals' ub1 more - - invertLowerBound :: LowerBound -> UpperBound - invertLowerBound (LowerBound v b) = UpperBound v (invertBound b) - - invertUpperBound :: UpperBound -> LowerBound - invertUpperBound (UpperBound v b) = LowerBound v (invertBound b) - invertUpperBound NoUpperBound = error "NoUpperBound: unexpected" - - invertBound :: Bound -> Bound - invertBound ExclusiveBound = InclusiveBound - invertBound InclusiveBound = ExclusiveBound - - noLowerBound :: LowerBound - noLowerBound = LowerBound (mkVersion [0]) InclusiveBound - - -relaxLastInterval :: VersionIntervals -> VersionIntervals -relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs) - where - relaxLastInterval' [] = [] - relaxLastInterval' [(l,_)] = [(l, NoUpperBound)] - relaxLastInterval' (i:is) = i : relaxLastInterval' is - -relaxHeadInterval :: VersionIntervals -> VersionIntervals -relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs) - where - relaxHeadInterval' [] = [] - relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is diff --git a/src/Distribution/Types/VersionRange.hs b/src/Distribution/Types/VersionRange.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionRange.hs +++ /dev/null @@ -1,180 +0,0 @@ -module Distribution.Types.VersionRange ( - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - -- - -- See "Distribution.Version" for more utilities. - withinRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - isAnyVersion, - isAnyVersionLight, - wildcardUpperBound, - majorUpperBound, - isWildcardRange, - versionRangeParser, - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Distribution.Types.VersionInterval -import Distribution.Types.VersionRange.Internal -import Prelude () - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntactic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange _any this later earlier union intersect = fold - where - fold = cataVersionRange alg - - alg (ThisVersionF v) = this v - alg (LaterVersionF v) = later v - alg (OrLaterVersionF v) = union (this v) (later v) - alg (EarlierVersionF v) = earlier v - alg (OrEarlierVersionF v) = union (this v) (earlier v) - alg (MajorBoundVersionF v) = fold (majorBound v) - alg (UnionVersionRangesF v1 v2) = union v1 v2 - alg (IntersectVersionRangesF v1 v2) = intersect v1 v2 - - majorBound v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (majorUpperBound v)) - --- | Normalise 'VersionRange'. --- --- In particular collapse @(== v || > v)@ into @>= v@, and so on. -normaliseVersionRange :: VersionRange -> VersionRange -normaliseVersionRange = hyloVersionRange embed projectVersionRange - where - -- == v || > v, > v || == v ==> >= v - embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' = - orLaterVersion v - embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' = - orLaterVersion v - - -- == v || < v, < v || == v ==> <= v - embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' = - orEarlierVersion v - embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' = - orEarlierVersion v - - -- otherwise embed normally - embed vr = embedVersionRange vr - --- | Remove 'VersionRangeParens' constructors. --- --- Since version 3.4 this function is 'id', there aren't 'VersionRangeParens' constructor in 'VersionRange' anymore. --- --- @since 2.2 -stripParensVersionRange :: VersionRange -> VersionRange -stripParensVersionRange = id - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> v == v') - (\v' -> v > v') - (\v' -> v < v') - (||) - (&&) - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0 - _ -> False - --- A fast and non-precise version of 'isAnyVersion', --- returns 'True' only for @>= 0@ 'VersionRange's. --- --- /Do not use/. The "VersionIntervals don't destroy MajorBoundVersion" --- https://github.com/haskell/cabal/pull/6736 pull-request --- will change 'simplifyVersionRange' to properly preserve semantics. --- Then we can use it to normalise 'VersionRange's in tests. --- -isAnyVersionLight :: VersionRange -> Bool -isAnyVersionLight (OrLaterVersion v) = v == version0 -isAnyVersionLight _vr = False - ----------------------------- --- Wildcard range utilities --- - - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2) - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - --- | Does the version range have an upper bound? --- --- @since 1.24.0.0 -hasUpperBound :: VersionRange -> Bool -hasUpperBound = foldVersionRange - False - (const True) - (const False) - (const True) - (&&) (||) - --- | Does the version range have an explicit lower bound? --- --- Note: this function only considers the user-specified lower bounds, but not --- the implicit >=0 lower bound. --- --- @since 1.24.0.0 -hasLowerBound :: VersionRange -> Bool -hasLowerBound = foldVersionRange - False - (const True) - (const True) - (const False) - (&&) (||) diff --git a/src/Distribution/Types/VersionRange/Internal.hs b/src/Distribution/Types/VersionRange/Internal.hs deleted file mode 100644 --- a/src/Distribution/Types/VersionRange/Internal.hs +++ /dev/null @@ -1,526 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | The only purpose of this module is to prevent the export of --- 'VersionRange' constructors from --- 'Distribution.Types.VersionRange'. To avoid creating orphan --- instances, a lot of related code had to be moved here too. - -module Distribution.Types.VersionRange.Internal - ( VersionRange(..) - , anyVersion, noVersion - , thisVersion, notThisVersion - , laterVersion, earlierVersion - , orLaterVersion, orEarlierVersion - , unionVersionRanges, intersectVersionRanges - , withinVersion - , majorBoundVersion - - , VersionRangeF(..) - , projectVersionRange - , embedVersionRange - , cataVersionRange - , anaVersionRange - , hyloVersionRange - , versionRangeParser - - , majorUpperBound - , wildcardUpperBound - ) where - -import Distribution.Compat.Prelude -import Distribution.Types.Version -import Prelude () - -import Distribution.CabalSpecVersion -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (unsnoc) - -import qualified Distribution.Compat.CharParsing as P -import qualified Distribution.Compat.DList as DList -import qualified Text.PrettyPrint as Disp - -data VersionRange - = ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | OrLaterVersion Version -- >= version - | EarlierVersion Version -- < version - | OrEarlierVersion Version -- <= version - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - deriving ( Data, Eq, Generic, Read, Show, Typeable ) - -instance Binary VersionRange -instance Structured VersionRange -instance NFData VersionRange where rnf = genericRnf - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = OrLaterVersion (mkVersion [0]) - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @< 0@. --- --- > withinRange v noVersion = False --- -noVersion :: VersionRange -noVersion = EarlierVersion (mkVersion [0]) - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion = OrLaterVersion - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion = OrEarlierVersion - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - --- | The version range @^>= v@. --- --- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ --- is the same as @>= 1.2.3.4 && < 1.3@. --- --- Note that @^>= 1@ is equivalent to @>= 1 && < 1.1@. --- --- @since 2.0.0.2 -majorBoundVersion :: Version -> VersionRange -majorBoundVersion = MajorBoundVersion - - --- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. --- --- @since 2.2 -data VersionRangeF a - = ThisVersionF Version -- = version - | LaterVersionF Version -- > version (NB. not >=) - | OrLaterVersionF Version -- >= version - | EarlierVersionF Version -- < version - | OrEarlierVersionF Version -- <= version - | MajorBoundVersionF Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRangesF a a - | IntersectVersionRangesF a a - deriving ( Data, Eq, Generic, Read, Show, Typeable - , Functor, Foldable, Traversable ) - --- | @since 2.2 -projectVersionRange :: VersionRange -> VersionRangeF VersionRange -projectVersionRange (ThisVersion v) = ThisVersionF v -projectVersionRange (LaterVersion v) = LaterVersionF v -projectVersionRange (OrLaterVersion v) = OrLaterVersionF v -projectVersionRange (EarlierVersion v) = EarlierVersionF v -projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v -projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v -projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b -projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b - --- | Fold 'VersionRange'. --- --- @since 2.2 -cataVersionRange :: (VersionRangeF a -> a) -> VersionRange -> a -cataVersionRange f = c where c = f . fmap c . projectVersionRange - --- | @since 2.2 -embedVersionRange :: VersionRangeF VersionRange -> VersionRange -embedVersionRange (ThisVersionF v) = ThisVersion v -embedVersionRange (LaterVersionF v) = LaterVersion v -embedVersionRange (OrLaterVersionF v) = OrLaterVersion v -embedVersionRange (EarlierVersionF v) = EarlierVersion v -embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v -embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v -embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b -embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b - --- | Unfold 'VersionRange'. --- --- @since 2.2 -anaVersionRange :: (a -> VersionRangeF a) -> a -> VersionRange -anaVersionRange g = a where a = embedVersionRange . fmap a . g - --- | Refold 'VersionRange' --- --- @since 2.2 -hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange) - -> (VersionRange -> VersionRangeF VersionRange) - -> VersionRange -> VersionRange -hyloVersionRange f g = h where h = f . fmap h . g - -------------------------------------------------------------------------------- --- Parsec & Pretty -------------------------------------------------------------------------------- - --- | --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just >=3.2 && <3.3 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "== 3.2.*" :: Maybe VersionRange) --- Just ==3.2.* --- --- >>> fmap pretty (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- --- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange) --- Just >=0 --- -instance Pretty VersionRange where - pretty = prettyVersioned cabalSpecLatest - - prettyVersioned csv - | csv > CabalSpecV1_6 = prettyVersionRange - | otherwise = prettyVersionRange16 - -prettyVersionRange :: VersionRange -> Disp.Doc -prettyVersionRange vr = cataVersionRange alg vr 0 - where - alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc - alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v - alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v - alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v - alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v - alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v - alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v - alg (UnionVersionRangesF r1 r2) d = parens (d > 0) - $ r1 1 <+> Disp.text "||" <+> r2 0 - alg (IntersectVersionRangesF r1 r2) d = parens (d > 1) - $ r1 2 <+> Disp.text "&&" <+> r2 1 - - parens True = Disp.parens - parens False = id - --- | Don't use && and || operators. If possible. -prettyVersionRange16 :: VersionRange -> Disp.Doc -prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u)) - | u == wildcardUpperBound v - = Disp.text "==" <<>> dispWild v - where - dispWild ver = - Disp.hcat (Disp.punctuate (Disp.char '.') - (map Disp.int $ versionNumbers ver)) - <<>> Disp.text ".*" - -prettyVersionRange16 vr = prettyVersionRange vr - --- | --- --- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange --- Just (MajorBoundVersion (mkVersion [3,4])) --- --- Small history: --- --- @-any@ and @-none@ removed in 3.4 --- Use @>=0@ and @<0@ instead. --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe VersionRange] --- [Just (EarlierVersion (mkVersion [0])),Nothing] --- --- Set operations are introduced in 3.0 --- --- >>> map (`simpleParsec'` "^>= { 1.2 , 1.3 }") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (MajorBoundVersion (mkVersion [1,2])) (MajorBoundVersion (mkVersion [1,3])))] --- --- @^>=@ is introduced in 2.0 --- --- >>> map (`simpleParsec'` "^>=1.2") [CabalSpecV1_24, CabalSpecV2_0] :: [Maybe VersionRange] --- [Nothing,Just (MajorBoundVersion (mkVersion [1,2]))] --- --- @-none@ is introduced in 1.22 --- --- >>> map (`simpleParsec'` "-none") [CabalSpecV1_20, CabalSpecV1_22] :: [Maybe VersionRange] --- [Nothing,Just (EarlierVersion (mkVersion [0]))] --- --- Operators are introduced in 1.8. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1 || ==2") [CabalSpecV1_6, CabalSpecV1_8] :: [Maybe VersionRange] --- [Nothing,Just (UnionVersionRanges (ThisVersion (mkVersion [1])) (ThisVersion (mkVersion [2])))] --- --- Wild-version ranges are introduced in 1.6. Issues only a warning. --- --- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange] --- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))] --- -instance Parsec VersionRange where - parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser - --- | 'VersionRange' parser parametrised by version digit parser --- --- - 'versionDigitParser' is used for all 'VersionRange'. --- - 'P.integral' is used for backward-compat @pkgconfig-depends@ --- versions, 'PkgConfigVersionRange'. --- --- @since 3.0 -versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange -versionRangeParser digitParser csv = expr - where - expr = do P.spaces - t <- term - P.spaces - (do _ <- P.string "||" - checkOp - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> - return t) - term = do f <- factor - P.spaces - (do _ <- P.string "&&" - checkOp - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> - return f) - factor = parens expr <|> prim - - prim = do - op <- P.munch1 isOpChar P. "operator" - case op of - "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' - - "==" -> do - P.spaces - (do (wild, v) <- verOrWild - checkWild wild - pure $ (if wild then withinVersion else thisVersion) v - <|> - (verSet' thisVersion =<< verSet)) - - "^>=" -> do - P.spaces - (do (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after ^>= operator" - majorBoundVersion' v - <|> - (verSet' majorBoundVersion =<< verSet)) - - _ -> do - P.spaces - (wild, v) <- verOrWild - when wild $ P.unexpected $ - "wild-card version after non-== operator: " ++ show op - case op of - ">=" -> pure $ orLaterVersion v - "<" -> pure $ earlierVersion v - "<=" -> pure $ orEarlierVersion v - ">" -> pure $ laterVersion v - _ -> fail $ "Unknown version operator " ++ show op - - -- Cannot be warning - -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal - -- - checkOp = when (csv < CabalSpecV1_8) $ - parsecWarning PWTVersionOperator $ unwords - [ "version operators used." - , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'." - ] - - -- Cannot be warning - -- On 2020-03-16 there was 46 files on Hackage failing to parse due this - -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal - -- - checkWild False = pure () - checkWild True = when (csv < CabalSpecV1_6) $ - parsecWarning PWTVersionWildcard $ unwords - [ "Wildcard syntax used." - , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'." - ] - - -- https://gitlab.haskell.org/ghc/ghc/issues/17752 - isOpChar '<' = True - isOpChar '=' = True - isOpChar '>' = True - isOpChar '^' = True - isOpChar '-' = csv < CabalSpecV3_4 - -- https://github.com/haskell/cabal/issues/6589 - -- Unfortunately we have must not consume the dash, - -- as otherwise following parts may not be parsed. - -- - -- i.e. we cannot fail here with good error. - isOpChar _ = False - - -- -none version range is available since 1.22 - noVersion' = - if csv >= CabalSpecV1_22 - then pure noVersion - else fail $ unwords - [ "-none version range used." - , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'." - , "Alternatively, if broader compatibility is important then use" - , "<0 or other empty range." - ] - - -- ^>= is available since 2.0 - majorBoundVersion' v = - if csv >= CabalSpecV2_0 - then pure $ majorBoundVersion v - else fail $ unwords - [ "major bounded version syntax (caret, ^>=) used." - , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." - , "Alternatively, if broader compatibility is important then use:" - , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v - ] - where - eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange - embed (MajorBoundVersionF u) = intersectVersionRanges - (orLaterVersion u) (earlierVersion (majorUpperBound u)) - embed vr = embedVersionRange vr - - -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") - verSet' op vs = - if csv >= CabalSpecV3_0 - then pure $ foldr1 unionVersionRanges (fmap op vs) - else fail $ unwords - [ "version set syntax used." - , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." - , "Alternatively, if broader compatibility is important then use" - , "a series of single version constraints joined with the || operator:" - , prettyShow (foldr1 unionVersionRanges (fmap op vs)) - ] - - verSet :: CabalParsing m => m (NonEmpty Version) - verSet = do - _ <- P.char '{' - P.spaces - vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) - _ <- P.char '}' - pure vs - - -- a plain version without tags or wildcards - verPlain :: CabalParsing m => m Version - verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.') - - -- either wildcard or normal version - verOrWild :: CabalParsing m => m (Bool, Version) - verOrWild = do - x <- digitParser - verLoop (DList.singleton x) - - -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag) - verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop acc = verLoop' acc - <|> (tags *> pure (False, mkVersion (DList.toList acc))) - - verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version) - verLoop' acc = do - _ <- P.char '.' - let digit = digitParser >>= verLoop . DList.snoc acc - let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' - digit <|> wild - - parens p = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - $ do - a <- p - P.spaces - return a - - tags :: CabalParsing m => m () - tags = do - ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum) - case ts of - [] -> pure () - (_ : _) -> parsecWarning PWTVersionTag "version with tags" - - ----------------------------- --- Wildcard range utilities --- - --- | Compute next greater major version to be used as upper bound --- --- Example: @0.4.1@ produces the version @0.5@ which then can be used --- to construct a range @>= 0.4.1 && < 0.5@ --- --- @since 2.2 -majorUpperBound :: Version -> Version -majorUpperBound = alterVersion $ \numbers -> case numbers of - [] -> [0,1] -- should not happen - [m1] -> [m1,1] -- e.g. version '1' - (m1:m2:_) -> [m1,m2+1] - --- | @since 2.2 -wildcardUpperBound :: Version -> Version -wildcardUpperBound = alterVersion $ - \lowerBound -> case unsnoc lowerBound of - Nothing -> [] - Just (xs, x) -> xs ++ [x + 1] diff --git a/src/Distribution/Utils/Base62.hs b/src/Distribution/Utils/Base62.hs deleted file mode 100644 --- a/src/Distribution/Utils/Base62.hs +++ /dev/null @@ -1,22 +0,0 @@ - --- | Implementation of base-62 encoding, which we use when computing hashes --- for fully instantiated unit ids. -module Distribution.Utils.Base62 (hashToBase62) where - -import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) -import Numeric ( showIntAtBase ) -import Data.Char ( chr ) - --- | Hash a string using GHC's fingerprinting algorithm (a 128-bit --- MD5 hash) and then encode the resulting hash in base 62. -hashToBase62 :: String -> String -hashToBase62 s = showFingerprint $ fingerprintString s - where - showIntAtBase62 x = showIntAtBase 62 representBase62 x "" - representBase62 x - | x < 10 = chr (48 + x) - | x < 36 = chr (65 + x - 10) - | x < 62 = chr (97 + x - 36) - | otherwise = '@' - showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b - diff --git a/src/Distribution/Utils/Generic.hs b/src/Distribution/Utils/Generic.hs deleted file mode 100644 --- a/src/Distribution/Utils/Generic.hs +++ /dev/null @@ -1,576 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE BangPatterns #-} - ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- License : BSD3 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -module Distribution.Utils.Generic ( - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - - -- * Unicode - - -- ** Conversions - fromUTF8BS, - fromUTF8LBS, - - toUTF8BS, - toUTF8LBS, - - validateUTF8, - - -- ** File I/O - readUTF8File, - withUTF8FileContents, - writeUTF8File, - - -- ** BOM - ignoreBOM, - - -- ** Misc - normaliseLineEndings, - - -- * generic utils - dropWhileEndLE, - takeWhileEndLE, - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - isAscii, - isAsciiAlpha, - isAsciiAlphaNum, - listUnion, - listUnionRight, - ordNub, - ordNubBy, - ordNubRight, - safeHead, - safeTail, - safeLast, - safeInit, - unintersperse, - wrapText, - wrapLine, - unfoldrM, - spanMaybe, - breakMaybe, - unsnoc, - unsnocNE, - - -- * Triples - fstOf3, - sndOf3, - trdOf3, - - -- * FilePath stuff - isAbsoluteOnAnyPlatform, - isRelativeOnAnyPlatform, - ) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Utils.String - -import Data.Bits ((.&.), (.|.), shiftL) -import Data.List - ( isInfixOf ) -import qualified Data.Set as Set -import qualified Data.ByteString as SBS -import qualified Data.ByteString.Lazy as LBS - -import System.Directory - ( removeFile, renameFile ) -import System.FilePath - ( (<.>), splitFileName ) -import System.IO - ( withFile, withBinaryFile - , openBinaryTempFileWithDefaultPermissions - , IOMode(ReadMode), hGetContents, hClose ) -import qualified Control.Exception as Exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . map (intercalate "\n" - . map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - withFile name ReadMode - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written successfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> LBS.ByteString -> IO () -writeFileAtomic targetPath content = do - let (targetDir, targetFile) = splitFileName targetPath - Exception.bracketOnError - (openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp") - (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath) - (\(tmpPath, handle) -> do - LBS.hPut handle content - hClose handle - renameFile tmpPath targetPath) - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- | Decode 'String' from UTF8-encoded 'BS.ByteString' --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- -fromUTF8BS :: SBS.ByteString -> String -fromUTF8BS = decodeStringUtf8 . SBS.unpack - --- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's --- -fromUTF8LBS :: LBS.ByteString -> String -fromUTF8LBS = decodeStringUtf8 . LBS.unpack - --- | Encode 'String' to UTF8-encoded 'SBS.ByteString' --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- -toUTF8BS :: String -> SBS.ByteString -toUTF8BS = SBS.pack . encodeStringUtf8 - --- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's --- -toUTF8LBS :: String -> LBS.ByteString -toUTF8LBS = LBS.pack . encodeStringUtf8 - --- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not. -validateUTF8 :: SBS.ByteString -> Maybe Int -validateUTF8 = go 0 where - go off bs = case SBS.uncons bs of - Nothing -> Nothing - Just (c, bs') - | c <= 0x7F -> go (off + 1) bs' - | c <= 0xBF -> Just off - | c <= 0xDF -> twoBytes off c bs' - | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF) - | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7) - | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3) - | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1) - | otherwise -> Just off - - twoBytes off c0 bs = case SBS.uncons bs of - Nothing -> Just off - Just (c1, bs') - | c1 .&. 0xC0 == 0x80 -> - if d >= (0x80 :: Int) - then go (off + 2) bs' - else Just off - | otherwise -> Just off - where - d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F) - - moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int - moreBytes off 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = go (off + 1) cs' - - | otherwise - = Just off - - moreBytes off byteCount overlong bs acc = case SBS.uncons bs of - Just (cn, bs') | cn .&. 0xC0 == 0x80 -> - moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - _ -> Just off - - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - withBinaryFile name ReadMode - (\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8LBS - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - --- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but --- quite a bit faster. The difference between "Data.List.dropWhileEnd" and this --- version is that the one in "Data.List" is strict in elements, but spine-lazy, --- while this one is spine-strict but lazy in elements. That's what @LE@ stands --- for - "lazy in elements". --- --- Example: --- --- >>> safeTail $ Data.List.dropWhileEnd (<3) [undefined, 5, 4, 3, 2, 1] --- *** Exception: Prelude.undefined --- ... --- --- >>> safeTail $ dropWhileEndLE (<3) [undefined, 5, 4, 3, 2, 1] --- [5,4,3] --- --- >>> take 3 $ Data.List.dropWhileEnd (<3) [5, 4, 3, 2, 1, undefined] --- [5,4,3] --- --- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined] --- *** Exception: Prelude.undefined --- ... --- -dropWhileEndLE :: (a -> Bool) -> [a] -> [a] -dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] - --- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but --- is usually faster (as well as being easier to read). -takeWhileEndLE :: (a -> Bool) -> [a] -> [a] -takeWhileEndLE p = fst . foldr go ([], False) - where - go x (rest, done) - | not done && p x = (x:rest, False) - | otherwise = (rest, True) - --- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of --- @O(n^2)@. Code for 'ordNub' and 'listUnion' taken from Niklas Hambüchen's --- package. -ordNub :: Ord a => [a] -> [a] -ordNub = ordNubBy id - --- | Like 'ordNub' and 'Data.List.nubBy'. Selects a key for each element and --- takes the nub based on that key. -ordNubBy :: Ord b => (a -> b) -> [a] -> [a] -ordNubBy f l = go Set.empty l - where - go !_ [] = [] - go !s (x:xs) - | y `Set.member` s = go s xs - | otherwise = let !s' = Set.insert y s - in x : go s' xs - where - y = f x - --- | Like "Data.List.union", but has @O(n log n)@ complexity instead of --- @O(n^2)@. -listUnion :: (Ord a) => [a] -> [a] -> [a] -listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b) - where - aSet = Set.fromList a - --- | A right-biased version of 'ordNub'. --- --- Example: --- --- >>> ordNub [1,2,1] :: [Int] --- [1,2] --- --- >>> ordNubRight [1,2,1] :: [Int] --- [2,1] --- -ordNubRight :: (Ord a) => [a] -> [a] -ordNubRight = fst . foldr go ([], Set.empty) - where - go x p@(l, s) = if x `Set.member` s then p - else (x:l, Set.insert x s) - --- | A right-biased version of 'listUnion'. --- --- Example: --- --- >>> listUnion [1,2,3,4,3] [2,1,1] --- [1,2,3,4,3] --- --- >>> listUnionRight [1,2,3,4,3] [2,1,1] --- [4,3,2,1,1] --- -listUnionRight :: (Ord a) => [a] -> [a] -> [a] -listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b - where - bSet = Set.fromList b - --- | A total variant of 'head'. --- --- @since 3.2.0.0 -safeHead :: [a] -> Maybe a -safeHead [] = Nothing -safeHead (x:_) = Just x - --- | A total variant of 'tail'. --- --- @since 3.2.0.0 -safeTail :: [a] -> [a] -safeTail [] = [] -safeTail (_:xs) = xs - --- | A total variant of 'last'. --- --- @since 3.2.0.0 -safeLast :: [a] -> Maybe a -safeLast [] = Nothing -safeLast (x:xs) = Just (foldl (\_ a -> a) x xs) - --- | A total variant of 'init'. --- --- @since 3.2.0.0 -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit [_] = [] -safeInit (x:xs) = x : safeInit xs - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - --- | Lower case string --- --- >>> lowercase "Foobar" --- "foobar" -lowercase :: String -> String -lowercase = map toLower - --- | Ascii characters -isAscii :: Char -> Bool -isAscii c = fromEnum c < 0x80 - --- | Ascii letters. -isAsciiAlpha :: Char -> Bool -isAsciiAlpha c = ('a' <= c && c <= 'z') - || ('A' <= c && c <= 'Z') - --- | Ascii letters and digits. --- --- >>> isAsciiAlphaNum 'a' --- True --- --- >>> isAsciiAlphaNum 'ä' --- False --- -isAsciiAlphaNum :: Char -> Bool -isAsciiAlphaNum c = isAscii c && isAlphaNum c - -unintersperse :: Char -> String -> [String] -unintersperse mark = unfoldr unintersperse1 where - unintersperse1 str - | null str = Nothing - | otherwise = - let (this, rest) = break (== mark) str in - Just (this, safeTail rest) - --- | Like 'break', but with 'Maybe' predicate --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar", "1", "2", "quu"] --- (["foo","bar"],Just (1,["2","quu"])) --- --- >>> breakMaybe (readMaybe :: String -> Maybe Int) ["foo", "bar"] --- (["foo","bar"],Nothing) --- --- @since 2.2 --- -breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a])) -breakMaybe f = go id where - go !acc [] = (acc [], Nothing) - go !acc (x:xs) = case f x of - Nothing -> go (acc . (x:)) xs - Just b -> (acc [], Just (b, xs)) - --- | Like 'span' but with 'Maybe' predicate --- --- >>> spanMaybe listToMaybe [[1,2],[3],[],[4,5],[6,7]] --- ([1,3],[[],[4,5],[6,7]]) --- --- >>> spanMaybe (readMaybe :: String -> Maybe Int) ["1", "2", "foo"] --- ([1,2],["foo"]) --- --- @since 2.2 --- -spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) -spanMaybe _ xs@[] = ([], xs) -spanMaybe p xs@(x:xs') = case p x of - Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) - Nothing -> ([], xs) - --- | 'unfoldr' with monadic action. --- --- >>> take 5 $ unfoldrM (\b r -> Just (r + b, b + 1)) (1 :: Int) 2 --- [3,4,5,6,7] --- --- @since 2.2 --- -unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a] -unfoldrM f = go where - go b = do - m <- f b - case m of - Nothing -> return [] - Just (a, b') -> liftM (a :) (go b') - --- | The opposite of 'snoc', which is the reverse of 'cons' --- --- Example: --- --- >>> unsnoc [1, 2, 3] --- Just ([1,2],3) --- --- >>> unsnoc [] --- Nothing --- --- @since 3.2.0.0 --- -unsnoc :: [a] -> Maybe ([a], a) -unsnoc [] = Nothing -unsnoc (x:xs) = Just (unsnocNE (x :| xs)) - --- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe' --- --- Example: --- --- >>> unsnocNE (1 :| [2, 3]) --- ([1,2],3) --- --- >>> unsnocNE (1 :| []) --- ([],1) --- --- @since 3.2.0.0 --- -unsnocNE :: NonEmpty a -> ([a], a) -unsnocNE (x:|xs) = go x xs where - go y [] = ([], y) - go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w) - -------------------------------------------------------------------------------- --- Triples -------------------------------------------------------------------------------- - --- | @since 3.4.0.0 -fstOf3 :: (a,b,c) -> a -fstOf3 (a,_,_) = a - --- | @since 3.4.0.0 -sndOf3 :: (a,b,c) -> b -sndOf3 (_,b,_) = b - --- | @since 3.4.0.0 -trdOf3 :: (a,b,c) -> c -trdOf3 (_,_,c) = c - --- ------------------------------------------------------------ --- * FilePath stuff --- ------------------------------------------------------------ - --- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like --- 'System.FilePath.isAbsolute' and 'System.FilePath.isRelative' but have --- platform independent heuristics. --- The System.FilePath exists in two versions, Windows and Posix. The two --- versions don't agree on what is a relative path and we don't know if we're --- given Windows or Posix paths. --- This results in false positives when running on Posix and inspecting --- Windows paths, like the hackage server does. --- System.FilePath.Posix.isAbsolute \"C:\\hello\" == False --- System.FilePath.Windows.isAbsolute \"/hello\" == False --- This means that we would treat paths that start with \"/\" to be absolute. --- On Posix they are indeed absolute, while on Windows they are not. --- --- The portable versions should be used when we might deal with paths that --- are from another OS than the host OS. For example, the Hackage Server --- deals with both Windows and Posix paths while performing the --- PackageDescription checks. In contrast, when we run 'cabal configure' we --- do expect the paths to be correct for our OS and we should not have to use --- the platform independent heuristics. -isAbsoluteOnAnyPlatform :: FilePath -> Bool --- C:\\directory -isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive -isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive --- UNC -isAbsoluteOnAnyPlatform ('\\':'\\':_) = True --- Posix root -isAbsoluteOnAnyPlatform ('/':_) = True -isAbsoluteOnAnyPlatform _ = False - --- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@ -isRelativeOnAnyPlatform :: FilePath -> Bool -isRelativeOnAnyPlatform = not . isAbsoluteOnAnyPlatform - --- $setup --- >>> import Data.Maybe --- >>> import Text.Read diff --git a/src/Distribution/Utils/IOData.hs b/src/Distribution/Utils/IOData.hs --- a/src/Distribution/Utils/IOData.hs +++ b/src/Distribution/Utils/IOData.hs @@ -1,81 +1,86 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + -- | @since 2.2.0 module Distribution.Utils.IOData - ( -- * 'IOData' & 'IODataMode' type - IOData (..) - , IODataMode (..) - , KnownIODataMode (..) - , withIOData - , null - , hPutContents - ) where + ( -- * 'IOData' & 'IODataMode' type + IOData (..) + , IODataMode (..) + , KnownIODataMode (..) + , withIOData + , null + , hPutContents + ) where import qualified Data.ByteString.Lazy as LBS -import Distribution.Compat.Prelude hiding (null) -import qualified Prelude +import Distribution.Compat.Prelude hiding (null) import qualified System.IO +import qualified Prelude -- | Represents either textual or binary data passed via I/O functions -- which support binary/text mode -- -- @since 2.2 data IOData - = IODataText String - -- ^ How Text gets encoded is usually locale-dependent. - | IODataBinary LBS.ByteString - -- ^ Raw binary which gets read/written in binary mode. + = -- | How Text gets encoded is usually locale-dependent. + IODataText String + | -- | Raw binary which gets read/written in binary mode. + IODataBinary LBS.ByteString +-- | Applies a function polymorphic over 'IODataMode' to an 'IOData' value. withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r -withIOData (IODataText str) k = k IODataModeText str +withIOData (IODataText str) k = k IODataModeText str withIOData (IODataBinary lbs) k = k IODataModeBinary lbs -- | Test whether 'IOData' is empty null :: IOData -> Bool -null (IODataText s) = Prelude.null s +null (IODataText s) = Prelude.null s null (IODataBinary b) = LBS.null b instance NFData IOData where - rnf (IODataText s) = rnf s - rnf (IODataBinary lbs) = rnf lbs + rnf (IODataText s) = rnf s + rnf (IODataBinary lbs) = rnf lbs -- | @since 2.2 class NFData mode => KnownIODataMode mode where - -- | 'IOData' Wrapper for 'System.IO.hGetContents' - -- - -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all - -- data to be read and consequently the internal file handle to be - -- closed. - -- - hGetIODataContents :: System.IO.Handle -> Prelude.IO mode + -- | 'IOData' Wrapper for 'System.IO.hGetContents' + -- + -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all + -- data to be read and consequently the internal file handle to be + -- closed. + hGetIODataContents :: System.IO.Handle -> Prelude.IO mode - toIOData :: mode -> IOData - iodataMode :: IODataMode mode + toIOData :: mode -> IOData + iodataMode :: IODataMode mode --- | @since 3.2 +-- | Phantom-typed GADT representation of the mode of 'IOData', containing no +-- other data. +-- +-- @since 3.2 data IODataMode mode where - IODataModeText :: IODataMode String - IODataModeBinary :: IODataMode LBS.ByteString + IODataModeText :: IODataMode String + IODataModeBinary :: IODataMode LBS.ByteString instance a ~ Char => KnownIODataMode [a] where - hGetIODataContents h = do - System.IO.hSetBinaryMode h False - System.IO.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h False + System.IO.hGetContents h - toIOData = IODataText - iodataMode = IODataModeText + toIOData = IODataText + iodataMode = IODataModeText instance KnownIODataMode LBS.ByteString where - hGetIODataContents h = do - System.IO.hSetBinaryMode h True - LBS.hGetContents h + hGetIODataContents h = do + System.IO.hSetBinaryMode h True + LBS.hGetContents h - toIOData = IODataBinary - iodataMode = IODataModeBinary + toIOData = IODataBinary + iodataMode = IODataModeBinary -- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose' -- --- This is the dual operation ot 'hGetIODataContents', +-- This is the dual operation to 'hGetIODataContents', -- and consequently the handle is closed with `hClose`. -- -- /Note:/ this performs lazy-IO. @@ -83,10 +88,10 @@ -- @since 2.2 hPutContents :: System.IO.Handle -> IOData -> Prelude.IO () hPutContents h (IODataText c) = do - System.IO.hSetBinaryMode h False - System.IO.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h False + System.IO.hPutStr h c + System.IO.hClose h hPutContents h (IODataBinary c) = do - System.IO.hSetBinaryMode h True - LBS.hPutStr h c - System.IO.hClose h + System.IO.hSetBinaryMode h True + LBS.hPutStr h c + System.IO.hClose h diff --git a/src/Distribution/Utils/Json.hs b/src/Distribution/Utils/Json.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Utils/Json.hs @@ -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) diff --git a/src/Distribution/Utils/LogProgress.hs b/src/Distribution/Utils/LogProgress.hs --- a/src/Distribution/Utils/LogProgress.hs +++ b/src/Distribution/Utils/LogProgress.hs @@ -1,83 +1,84 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleContexts #-} -module Distribution.Utils.LogProgress ( - LogProgress, - runLogProgress, - warnProgress, - infoProgress, - dieProgress, - addProgressCtx, -) where +{-# LANGUAGE Rank2Types #-} -import Prelude () +module Distribution.Utils.LogProgress + ( LogProgress + , runLogProgress + , warnProgress + , infoProgress + , dieProgress + , addProgressCtx + ) where + import Distribution.Compat.Prelude +import Prelude () +import Distribution.Simple.Utils import Distribution.Utils.Progress import Distribution.Verbosity -import Distribution.Simple.Utils import Text.PrettyPrint type CtxMsg = Doc type LogMsg = Doc type ErrMsg = Doc -data LogEnv = LogEnv { - le_verbosity :: Verbosity, - le_context :: [CtxMsg] - } +data LogEnv = LogEnv + { le_verbosity :: Verbosity + , le_context :: [CtxMsg] + } -- | The 'Progress' monad with specialized logging and -- error messages. -newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a } +newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a} instance Functor LogProgress where - fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) + fmap f (LogProgress m) = LogProgress (fmap (fmap f) m) instance Applicative LogProgress where - pure x = LogProgress (pure (pure x)) - LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r + pure x = LogProgress (pure (pure x)) + LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r instance Monad LogProgress where - return = pure - LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r + return = pure + LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r -- | Run 'LogProgress', outputting traces according to 'Verbosity', -- 'die' if there is an error. runLogProgress :: Verbosity -> LogProgress a -> IO a runLogProgress verbosity (LogProgress m) = - foldProgress step_fn fail_fn return (m env) + foldProgress step_fn fail_fn return (m env) where - env = LogEnv { - le_verbosity = verbosity, - le_context = [] - } + env = + LogEnv + { le_verbosity = verbosity + , le_context = [] + } step_fn :: LogMsg -> IO a -> IO a step_fn doc go = do - putStrLn (render doc) - go + putStrLn (render doc) + go fail_fn :: Doc -> IO a fail_fn doc = do - dieNoWrap verbosity (render doc) + dieNoWrap verbosity (render doc) -- | Output a warning trace message in 'LogProgress'. warnProgress :: Doc -> LogProgress () warnProgress s = LogProgress $ \env -> - when (le_verbosity env >= normal) $ - stepProgress $ - hang (text "Warning:") 4 (formatMsg (le_context env) s) + when (le_verbosity env >= normal) $ + stepProgress $ + hang (text "Warning:") 4 (formatMsg (le_context env) s) -- | Output an informational trace message in 'LogProgress'. infoProgress :: Doc -> LogProgress () infoProgress s = LogProgress $ \env -> - when (le_verbosity env >= verbose) $ - stepProgress s + when (le_verbosity env >= verbose) $ + stepProgress s -- | Fail the computation with an error message. dieProgress :: Doc -> LogProgress a dieProgress s = LogProgress $ \env -> - failProgress $ - hang (text "Error:") 4 (formatMsg (le_context env) s) + failProgress $ + hang (text "Error:") 4 (formatMsg (le_context env) s) -- | Format a message with context. (Something simple for now.) formatMsg :: [CtxMsg] -> Doc -> Doc @@ -86,4 +87,4 @@ -- | Add a message to the error/warning context. addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a addProgressCtx s (LogProgress m) = LogProgress $ \env -> - m env { le_context = s : le_context env } + m env{le_context = s : le_context env} diff --git a/src/Distribution/Utils/MD5.hs b/src/Distribution/Utils/MD5.hs deleted file mode 100644 --- a/src/Distribution/Utils/MD5.hs +++ /dev/null @@ -1,79 +0,0 @@ -module Distribution.Utils.MD5 ( - MD5, - showMD5, - md5, - -- * Helpers - md5FromInteger, - -- * Binary - binaryPutMD5, - binaryGetMD5, - ) where - -import Data.Binary (Get, Put) -import Data.Binary.Get (getWord64le) -import Data.Binary.Put (putWord64le) -import Data.Bits (complement, shiftR, (.&.)) -import Foreign.Ptr (castPtr) -import GHC.Fingerprint (Fingerprint (..), fingerprintData) -import Numeric (showHex) -import System.IO.Unsafe (unsafeDupablePerformIO) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS - -type MD5 = Fingerprint - --- | Show 'MD5' in human readable form --- --- >>> showMD5 (Fingerprint 123 456) --- "000000000000007b00000000000001c8" --- --- >>> showMD5 $ md5 $ BS.pack [0..127] --- "37eff01866ba3f538421b30b7cbefcac" --- --- @since 3.2.0.0 -showMD5 :: MD5 -> String -showMD5 (Fingerprint a b) = pad a' ++ pad b' where - a' = showHex a "" - b' = showHex b "" - pad s = replicate (16 - length s) '0' ++ s - --- | @since 3.2.0.0 -md5 :: BS.ByteString -> MD5 -md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - fingerprintData (castPtr ptr) len - --- | @since 3.2.0.0 -binaryPutMD5 :: MD5 -> Put -binaryPutMD5 (Fingerprint a b) = do - putWord64le a - putWord64le b - --- | @since 3.2.0.0 -binaryGetMD5 :: Get MD5 -binaryGetMD5 = do - a <- getWord64le - b <- getWord64le - return (Fingerprint a b) - --- | --- --- >>> showMD5 $ md5FromInteger 0x37eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Note: the input is truncated: --- --- >>> showMD5 $ md5FromInteger 0x1230000037eff01866ba3f538421b30b7cbefcac --- "37eff01866ba3f538421b30b7cbefcac" --- --- Yet, negative numbers are not a problem... --- --- >>> showMD5 $ md5FromInteger (-1) --- "ffffffffffffffffffffffffffffffff" --- --- @since 3.4.0.0 -md5FromInteger :: Integer -> MD5 -md5FromInteger i = Fingerprint hi lo where - mask = complement 0 - lo = mask .&. fromInteger i - hi = mask .&. fromInteger (i `shiftR` 64) diff --git a/src/Distribution/Utils/MapAccum.hs b/src/Distribution/Utils/MapAccum.hs --- a/src/Distribution/Utils/MapAccum.hs +++ b/src/Distribution/Utils/MapAccum.hs @@ -1,34 +1,26 @@ -{-# LANGUAGE CPP #-} module Distribution.Utils.MapAccum (mapAccumM) where import Distribution.Compat.Prelude import Prelude () -- Like StateT but with return tuple swapped -newtype StateM s m a = StateM { runStateM :: s -> m (s, a) } +newtype StateM s m a = StateM {runStateM :: s -> m (s, a)} instance Functor m => Functor (StateM s m) where - fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) + fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s) -instance -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m) -#else - Monad m -#endif - => Applicative (StateM s m) where - pure x = StateM $ \s -> return (s, x) - StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s - (s'', x') <- x s' - return (s'', f' x') +instance Monad m => Applicative (StateM s m) where + pure x = StateM $ \s -> return (s, x) + StateM f <*> StateM x = StateM $ \s -> do + (s', f') <- f s + (s'', x') <- x s' + return (s'', f' x') -- | Monadic variant of 'mapAccumL'. -mapAccumM :: -#if __GLASGOW_HASKELL__ < 709 - (Functor m, Monad m, Traversable t) -#else - (Monad m, Traversable t) -#endif - => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c) +mapAccumM + :: (Monad m, Traversable t) + => (a -> b -> m (a, c)) + -> a + -> t b + -> m (a, t c) mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s - diff --git a/src/Distribution/Utils/NubList.hs b/src/Distribution/Utils/NubList.hs --- a/src/Distribution/Utils/NubList.hs +++ b/src/Distribution/Utils/NubList.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -module Distribution.Utils.NubList - ( NubList -- opaque - , toNubList -- smart construtor - , fromNubList - , overNubList - , NubListR - , toNubListR - , fromNubListR - , overNubListR - ) where +module Distribution.Utils.NubList + ( NubList -- opaque + , toNubList -- smart constructor + , fromNubList + , overNubList + , NubListR + , toNubListR + , fromNubListR + , overNubListR + ) where import Distribution.Compat.Prelude import Prelude () @@ -21,9 +20,8 @@ import qualified Text.Read as R -- | NubList : A de-duplicated list that maintains the original order. -newtype NubList a = - NubList { fromNubList :: [a] } - deriving (Eq, Generic, Typeable) +newtype NubList a = NubList {fromNubList :: [a]} + deriving (Eq, Generic) -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurrence). Documentation for "Data.List.nub" @@ -39,7 +37,7 @@ overNubList f (NubList list) = toNubList . f $ list -- | Monoid operations on NubLists. --- For a valid Monoid instance we need to satistfy the required monoid laws; +-- For a valid Monoid instance we need to satisfy the required monoid laws; -- identity, associativity and closure. -- -- Identity : by inspection: @@ -51,30 +49,29 @@ -- -- Closure : appending two lists of type a and removing duplicates obviously -- does not change the type. - instance Ord a => Monoid (NubList a) where - mempty = NubList [] - mappend = (<>) + mempty = NubList [] + mappend = (<>) instance Ord a => Semigroup (NubList a) where - (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys + (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys instance Show a => Show (NubList a) where - show (NubList list) = show list + show (NubList list) = show list instance (Ord a, Read a) => Read (NubList a) where - readPrec = readNubList toNubList + readPrec = readNubList toNubList -- | Helper used by NubList/NubListR's Read instances. -readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a) +readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec -- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we -- just pull off constructor and put the list. For 'get', we get the list and -- make a 'NubList' out of it using 'toNubList'. instance (Ord a, Binary a) => Binary (NubList a) where - put (NubList l) = put l - get = fmap toNubList get + put (NubList l) = put l + get = fmap toNubList get instance Structured a => Structured (NubList a) @@ -82,9 +79,8 @@ -- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@, -- unlike the normal 'NubList', which is left-biased. Built on top of -- 'ordNubRight' and 'listUnionRight'. -newtype NubListR a = - NubListR { fromNubListR :: [a] } - deriving Eq +newtype NubListR a = NubListR {fromNubListR :: [a]} + deriving (Eq) -- | Smart constructor for the NubListR type. toNubListR :: Ord a => [a] -> NubListR a @@ -105,4 +101,4 @@ show (NubListR list) = show list instance (Ord a, Read a) => Read (NubListR a) where - readPrec = readNubList toNubListR + readPrec = readNubList toNubListR diff --git a/src/Distribution/Utils/Path.hs b/src/Distribution/Utils/Path.hs deleted file mode 100644 --- a/src/Distribution/Utils/Path.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -module Distribution.Utils.Path ( - -- * Symbolic path - SymbolicPath, - getSymbolicPath, - sameDirectory, - unsafeMakeSymbolicPath, - -- * Path ends - PackageDir, - SourceDir, - LicenseFile, - IsDir, -) where - -import Prelude () -import Distribution.Compat.Prelude - -import Distribution.Parsec -import Distribution.Pretty -import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform) - -import qualified Distribution.Compat.CharParsing as P --- import qualified Text.PrettyPrint as Disp - -------------------------------------------------------------------------------- --- * SymbolicPath -------------------------------------------------------------------------------- - --- | Symbolic paths. --- --- These paths are system independent and relative. --- They are *symbolic* which means we cannot perform any 'IO' --- until we interpret them. --- -newtype SymbolicPath from to = SymbolicPath FilePath - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary (SymbolicPath from to) -instance (Typeable from, Typeable to) => Structured (SymbolicPath from to) -instance NFData (SymbolicPath from to) where rnf = genericRnf - --- | Extract underlying 'FilePath'. --- --- Avoid using this in new code. --- -getSymbolicPath :: SymbolicPath from to -> FilePath -getSymbolicPath (SymbolicPath p) = p - -sameDirectory :: (IsDir from, IsDir to) => SymbolicPath from to -sameDirectory = SymbolicPath "." - --- | Make 'SymbolicPath' without performing any checks. -unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to -unsafeMakeSymbolicPath = SymbolicPath - -------------------------------------------------------------------------------- --- ** Parsing and pretty printing -------------------------------------------------------------------------------- - -instance Parsec (SymbolicPath from to) where - parsec = do - token <- parsecToken - if null token then P.unexpected "empty FilePath" - else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath" - else return (SymbolicPath token) -- TODO: normalise - -instance Pretty (SymbolicPath from to) where - pretty = showFilePath . getSymbolicPath - -------------------------------------------------------------------------------- --- * Composition -------------------------------------------------------------------------------- - --- TODO --- infixr 5 --- --- -- | Path composition --- -- --- -- We don't reuse @@ name to not clash with "System.FilePath". --- -- --- () :: path a b -> path b c -> path a c - -------------------------------------------------------------------------------- --- * Path ends -------------------------------------------------------------------------------- - --- | Class telling that index is for directories. -class IsDir dir - -data PackageDir deriving (Typeable) -data SourceDir deriving (Typeable) - -data LicenseFile deriving (Typeable) - --- These instances needs to be derived standalone at least on GHC-7.6 -deriving instance Data PackageDir -deriving instance Data SourceDir -deriving instance Data LicenseFile - -instance IsDir PackageDir -instance IsDir SourceDir diff --git a/src/Distribution/Utils/Progress.hs b/src/Distribution/Utils/Progress.hs --- a/src/Distribution/Utils/Progress.hs +++ b/src/Distribution/Utils/Progress.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} + -- Note: This module was copied from cabal-install. -- | A progress monad, which we use to report failure and logging from -- otherwise pure code. module Distribution.Utils.Progress - ( Progress - , stepProgress - , failProgress - , foldProgress - ) where + ( Progress + , stepProgress + , failProgress + , foldProgress + ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import qualified Data.Monoid as Mon - -- | A type to represent the unfolding of an expensive long running -- calculation that may fail (or maybe not expensive, but complicated!) -- We may get intermediate steps before the final @@ -25,14 +24,13 @@ -- TODO: Apply Codensity to avoid left-associativity problem. -- See http://comonad.com/reader/2011/free-monads-for-less/ and -- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/ --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done +data Progress step fail done + = Step step (Progress step fail done) + | Fail fail + | Done done deriving (Functor) -- | Emit a step and then continue. --- stepProgress :: step -> Progress step fail () stepProgress step = Step step (Done ()) @@ -46,22 +44,26 @@ -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a +foldProgress + :: (step -> a -> a) + -> (fail -> a) + -> (done -> a) + -> Progress step fail done + -> a foldProgress step err done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = err f - fold (Done r) = done r + where + fold (Step s p) = step s (fold p) + fold (Fail f) = err f + fold (Done r) = done r instance Monad (Progress step fail) where - return = pure - p >>= f = foldProgress Step Fail f p + return = pure + p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where - pure a = Done a + pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where - empty = Fail Mon.mempty + empty = Fail Mon.mempty p <|> q = foldProgress Step (const q) Done p diff --git a/src/Distribution/Utils/ShortText.hs b/src/Distribution/Utils/ShortText.hs deleted file mode 100644 --- a/src/Distribution/Utils/ShortText.hs +++ /dev/null @@ -1,159 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} - --- | Compact representation of short 'Strings' --- --- This module is designed to be import qualifeid --- --- @ --- import Distribution.Utils.ShortText (ShortText) --- import qualified Distribution.Utils.ShortText as ShortText --- @ -module Distribution.Utils.ShortText - ( -- * 'ShortText' type - ShortText - , toShortText - , fromShortText - , unsafeFromUTF8BS - - -- * Operations - , null - , length - - -- * internal utilities - , decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Distribution.Compat.Prelude hiding (length, null) -import Prelude () - -import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8) -import Distribution.Utils.Structured (Structured (..), nominalStructure) - -#if defined(MIN_VERSION_bytestring) -# if MIN_VERSION_bytestring(0,10,4) -# define HAVE_SHORTBYTESTRING 1 -# endif -#endif - --- Hack for GHC bootstrapping --- --- Currently (as of GHC 8.1), GHC bootstraps Cabal by building --- binary and Cabal in one giant ghc --make command. This --- means no MIN_VERSION_binary macro is available. --- --- We could try to cleverly figure something out in this case, --- but there is a better plan: just use the unoptimized version --- of the Binary instance. We're not going to use it for anything --- real in any case. --- --- WARNING: Don't use MIN_VERSION_binary to smooth over a BC-break! --- -#ifndef MIN_VERSION_binary -#define MIN_VERSION_binary(x, y, z) 0 -#endif - -import qualified Data.ByteString as BS -import qualified Data.List as List - -#if HAVE_SHORTBYTESTRING -import qualified Data.ByteString.Short as BS.Short -#else -import Distribution.Utils.Generic (fromUTF8BS) -#endif - --- | Construct 'ShortText' from 'String' -toShortText :: String -> ShortText - --- | Convert 'ShortText' to 'String' -fromShortText :: ShortText -> String - --- | Convert from UTF-8 encoded strict 'ByteString'. --- --- @since 3.2.0.0 -unsafeFromUTF8BS :: BS.ByteString -> ShortText - --- | Text whether 'ShortText' is empty. --- --- @since 3.2.0.0 -null :: ShortText -> Bool - --- | Compact representation of short 'Strings' --- --- The data is stored internally as UTF8 in an --- 'BS.Short.ShortByteString' when compiled against @bytestring >= --- 0.10.4@, and otherwise the fallback is to use plain old non-compat --- '[Char]'. --- --- Note: This type is for internal uses (such as e.g. 'PackageName') --- and shall not be exposed in Cabal's API --- --- @since 2.0.0.2 -#if HAVE_SHORTBYTESTRING -newtype ShortText = ST { unST :: BS.Short.ShortByteString } - deriving (Eq,Ord,Generic,Data,Typeable) - -# if MIN_VERSION_binary(0,8,1) -instance Binary ShortText where - put = put . unST - get = fmap ST get -# else -instance Binary ShortText where - put = put . BS.Short.fromShort . unST - get = fmap (ST . BS.Short.toShort) get -# endif - - -toShortText = ST . BS.Short.pack . encodeStringUtf8 - -fromShortText = decodeStringUtf8 . BS.Short.unpack . unST - -unsafeFromUTF8BS = ST . BS.Short.toShort - -null = BS.Short.null . unST -#else -newtype ShortText = ST { unST :: String } - deriving (Eq,Ord,Generic,Data,Typeable) - -instance Binary ShortText where - put = put . encodeStringUtf8 . unST - get = fmap (ST . decodeStringUtf8) get - -toShortText = ST - -fromShortText = unST - -unsafeFromUTF8BS = ST . fromUTF8BS - -null = List.null . unST -#endif - -instance Structured ShortText where structure = nominalStructure - -instance NFData ShortText where - rnf = rnf . unST - -instance Show ShortText where - show = show . fromShortText - -instance Read ShortText where - readsPrec p = map (first toShortText) . readsPrec p - -instance Semigroup ShortText where - ST a <> ST b = ST (mappend a b) - -instance Monoid ShortText where - mempty = ST mempty - mappend = (<>) - -instance IsString ShortText where - fromString = toShortText - --- | /O(n)/. Length in characters. /Slow/ as converts to string. --- --- @since 3.2.0.0 -length :: ShortText -> Int -length = List.length . fromShortText --- Note: avoid using it, we use it @cabal check@ implementation, where it's ok. diff --git a/src/Distribution/Utils/String.hs b/src/Distribution/Utils/String.hs deleted file mode 100644 --- a/src/Distribution/Utils/String.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Distribution.Utils.String - ( -- * Encode to/from UTF8 - decodeStringUtf8 - , encodeStringUtf8 - ) where - -import Data.Word -import Data.Bits -import Data.Char (chr,ord) - --- | Decode 'String' from UTF8-encoded octets. --- --- Invalid data in the UTF8 stream (this includes code-points @U+D800@ --- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@). --- --- See also 'encodeStringUtf8' -decodeStringUtf8 :: [Word8] -> String -decodeStringUtf8 = go - where - go :: [Word8] -> String - go [] = [] - go (c : cs) - | c <= 0x7F = chr (fromIntegral c) : go cs - | c <= 0xBF = replacementChar : go cs - | c <= 0xDF = twoBytes c cs - | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF) - | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7) - | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3) - | c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1) - | otherwise = replacementChar : go cs - - twoBytes :: Word8 -> [Word8] -> String - twoBytes c0 (c1:cs') - | c1 .&. 0xC0 == 0x80 - = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) - .|. fromIntegral (c1 .&. 0x3F) - in if d >= 0x80 - then chr d : go cs' - else replacementChar : go cs' - twoBytes _ cs' = replacementChar : go cs' - - moreBytes :: Int -> Int -> [Word8] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc - = chr acc : go cs' - - | otherwise - = replacementChar : go cs' - - moreBytes byteCount overlong (cn:cs') acc - | cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : go cs' - - replacementChar = '\xfffd' - - --- | Encode 'String' to a list of UTF8-encoded octets --- --- Code-points in the @U+D800@-@U+DFFF@ range will be encoded --- as the replacement character (i.e. @U+FFFD@). --- --- See also 'decodeUtf8' -encodeStringUtf8 :: String -> [Word8] -encodeStringUtf8 [] = [] -encodeStringUtf8 (c:cs) - | c <= '\x07F' = w8 - : encodeStringUtf8 cs - | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD - : encodeStringUtf8 cs - | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - | otherwise = (0xf0 .|. w8ShiftR 18 ) - : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) - : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) - : (0x80 .|. (w8 .&. 0x3F)) - : encodeStringUtf8 cs - where - w8 = fromIntegral (ord c) :: Word8 - w8ShiftR :: Int -> Word8 - w8ShiftR = fromIntegral . shiftR (ord c) diff --git a/src/Distribution/Utils/Structured.hs b/src/Distribution/Utils/Structured.hs deleted file mode 100644 --- a/src/Distribution/Utils/Structured.hs +++ /dev/null @@ -1,477 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 711 -{-# LANGUAGE PatternSynonyms #-} -#endif -#if __GLASGOW_HASKELL__ >= 800 -{-# LANGUAGE TypeInType #-} -#endif --- | --- --- Copyright: (c) 2019 Oleg Grenrus --- --- Structurally tag binary serialisaton stream. --- Useful when most 'Binary' instances are 'Generic' derived. --- --- Say you have a data type --- --- @ --- data Record = Record --- { _recordFields :: HM.HashMap Text (Integer, ByteString) --- , _recordEnabled :: Bool --- } --- deriving (Eq, Show, Generic) --- --- instance 'Binary' Record --- instance 'Structured' Record --- @ --- --- then you can serialise and deserialise @Record@ values with a structure tag by simply --- --- @ --- 'structuredEncode' record :: 'LBS.ByteString' --- 'structuredDecode' lbs :: IO Record --- @ --- --- If structure of @Record@ changes in between, deserialisation will fail early. --- --- Technically, 'Structured' is not related to 'Binary', and may --- be useful in other uses. --- -module Distribution.Utils.Structured ( - -- * Encoding and decoding - -- | These functions operate like @binary@'s counterparts, - -- but the serialised version has a structure hash in front. - structuredEncode, - structuredEncodeFile, - structuredDecode, - structuredDecodeOrFailIO, - structuredDecodeFileOrFail, - -- * Structured class - Structured (structure), - MD5, - structureHash, - structureBuilder, - genericStructure, - GStructured, - nominalStructure, - containerStructure, - -- * Structure type - Structure (..), - Tag (..), - TypeName, - ConstructorName, - TypeVersion, - SopStructure, - hashStructure, - typeVersion, - typeName, - ) where - -import Data.Int (Int16, Int32, Int64, Int8) -import Data.List.NonEmpty (NonEmpty) -import Data.Proxy (Proxy (..)) -import Data.Ratio (Ratio) -import Data.Word (Word, Word16, Word32, Word64, Word8) - -import qualified Control.Monad.Trans.State.Strict as State - -import Control.Exception (ErrorCall (..), catch, evaluate) - -import GHC.Generics - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -#if MIN_VERSION_bytestring(0,10,4) -import qualified Data.ByteString.Builder as Builder -#else -import qualified Data.ByteString.Lazy.Builder as Builder -#endif -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Set as Set -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.Time as Time -import qualified Distribution.Compat.Binary as Binary - -#ifdef MIN_VERSION_aeson -import qualified Data.Aeson as Aeson -#endif - -#if __GLASGOW_HASKELL__ >= 800 -import Data.Kind (Type) -#else -#define Type * -#endif - -import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep) -import Distribution.Utils.MD5 - -import Data.Monoid (mconcat) - -import qualified Data.Semigroup -import qualified Data.Foldable - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure) -import Data.Traversable (traverse) -#endif - -#if !MIN_VERSION_base(4,7,0) -import Data.Typeable (Typeable1, typeOf1) -#endif - - -------------------------------------------------------------------------------- --- Types -------------------------------------------------------------------------------- - -type TypeName = String -type ConstructorName = String - --- | A sematic version of a data type. Usually 0. -type TypeVersion = Word32 - --- | Structure of a datatype. --- --- It can be infinite, as far as 'TypeRep's involved are finite. --- (e.g. polymorphic recursion might cause troubles). --- -data Structure - = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures. - | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper - | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure - deriving (Eq, Ord, Show, Generic) - -type SopStructure = [(ConstructorName, [Structure])] - --- | A MD5 hash digest of 'Structure'. -hashStructure :: Structure -> MD5 -hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder - --- | A van-Laarhoven lens into 'TypeVersion' of 'Structure' --- --- @ --- 'typeVersion' :: Lens' 'Structure' 'TypeVersion' --- @ -typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure -typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v) -typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v) -typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v) - --- | A van-Laarhoven lens into 'TypeName' of 'Structure' --- --- @ --- 'typeName' :: Lens' 'Structure' 'TypeName' --- @ -typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure -typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n) -typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n) -typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n) - -------------------------------------------------------------------------------- --- Builder -------------------------------------------------------------------------------- - --- | Flatten 'Structure' into something we can calculate hash of. --- --- As 'Structure' can be potentially infinite. For mutually recursive types, --- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred --- another time. -structureBuilder :: Structure -> Builder.Builder -structureBuilder s0 = State.evalState (go s0) Map.empty where - go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - go (Nominal t v n s) = withTypeRep t $ do - s' <- traverse go s - return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s' - - go (Newtype t v n s) = withTypeRep t $ do - s' <- go s - return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s'] - - go (Structure t v n s) = withTypeRep t $ do - s' <- goSop s - return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s'] - - withTypeRep t k = do - acc <- State.get - case insert t acc of - Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ] - Just acc' -> do - State.put acc' - k - - goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder - goSop sop = do - parts <- traverse part sop - return $ mconcat parts - - part (cn, s) = do - s' <- traverse go s - return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ] - - insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep)) - insert tr m = case Map.lookup trShown m of - Nothing -> inserted - Just ne | tr `Data.Foldable.elem` ne -> Nothing - | otherwise -> inserted - where - inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m) - trShown = show tr - -------------------------------------------------------------------------------- --- Classes -------------------------------------------------------------------------------- - --- | Class of types with a known 'Structure'. --- --- For regular data types 'Structured' can be derived generically. --- --- @ --- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic') --- instance 'Structured' Record --- @ --- --- @since 3.2.0.0 --- -class Typeable a => Structured a where - structure :: Proxy a -> Structure - default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure - structure = genericStructure - - -- This member is hidden. It's there to precalc - structureHash' :: Tagged a MD5 - structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a))) - --- private Tagged -newtype Tagged a b = Tagged { untag :: b } - --- | Semantically @'hashStructure' . 'structure'@. -structureHash :: forall a. Structured a => Proxy a -> MD5 -structureHash _ = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Functions -------------------------------------------------------------------------------- - --- | Structured 'Binary.encode'. --- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'. --- Encoding starts with 16 byte large structure hash. -structuredEncode - :: forall a. (Binary.Binary a, Structured a) - => a -> LBS.ByteString -structuredEncode x = Binary.encode (Tag :: Tag a, x) - --- | Lazily serialise a value to a file -structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO () -structuredEncodeFile f = LBS.writeFile f . structuredEncode - --- | Structured 'Binary.decode'. --- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure. --- Throws pure exception on invalid inputs. -structuredDecode - :: forall a. (Binary.Binary a, Structured a) - => LBS.ByteString -> a -structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a)) - -structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a) -structuredDecodeOrFailIO bs = - catch (evaluate (structuredDecode bs) >>= return . Right) handler - where -#if MIN_VERSION_base(4,9,0) - handler (ErrorCallWithLocation str _) = return $ Left str -#else - handler (ErrorCall str) = return $ Left str -#endif - --- | Lazily reconstruct a value previously written to a file. -structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a) -structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f - -------------------------------------------------------------------------------- --- Helper data -------------------------------------------------------------------------------- - -data Tag a = Tag - -instance Structured a => Binary.Binary (Tag a) where - get = do - actual <- binaryGetMD5 - if actual == expected - then return Tag - else fail $ concat - [ "Non-matching structured hashes: " - , showMD5 actual - , "; expected: " - , showMD5 expected - ] - where - expected = untag (structureHash' :: Tagged a MD5) - - put _ = binaryPutMD5 expected - where - expected = untag (structureHash' :: Tagged a MD5) - -------------------------------------------------------------------------------- --- Smart constructors -------------------------------------------------------------------------------- - --- | Use 'Typeable' to infer name -nominalStructure :: Typeable a => Proxy a -> Structure -nominalStructure p = Nominal tr 0 (show tr) [] where - tr = typeRep p - -#if MIN_VERSION_base(4,7,0) -containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeRep (Proxy :: Proxy f) - faTypeRep = typeRep (Proxy :: Proxy (f a)) - -#else -containerStructure :: forall f a. (Typeable1 f, Structured a) => Proxy (f a) -> Structure -containerStructure _ = Nominal faTypeRep 0 (show fTypeRep) - [ structure (Proxy :: Proxy a) - ] - where - fTypeRep = typeOf1 (undefined :: f ()) - faTypeRep = typeRep (Proxy :: Proxy (f a)) -#endif - -------------------------------------------------------------------------------- --- Generic -------------------------------------------------------------------------------- - --- | Derive 'structure' genrically. -genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure -genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0 - --- | Used to implement 'genericStructure'. -class GStructured (f :: Type -> Type) where - gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure - -instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where - gstructured tr _ v = case sop of -#if MIN_VERSION_base(4,7,0) - [(_, [s])] | isNewtype p -> Newtype tr v name s -#endif - _ -> Structure tr v name sop - where - p = undefined :: M1 i c f () - name = datatypeName p - sop = gstructuredSum (Proxy :: Proxy f) [] - -class GStructuredSum (f :: Type -> Type) where - gstructuredSum :: Proxy f -> SopStructure -> SopStructure - -instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where - gstructuredSum _ xs = (name, prod) : xs - where - name = conName (undefined :: M1 i c f ()) - prod = gstructuredProd (Proxy :: Proxy f) [] - -instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where - gstructuredSum _ xs - = gstructuredSum (Proxy :: Proxy f) - $ gstructuredSum (Proxy :: Proxy g) xs - -instance GStructuredSum V1 where - gstructuredSum _ = id - -class GStructuredProd (f :: Type -> Type) where - gstructuredProd :: Proxy f -> [Structure] -> [Structure] - -instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where - gstructuredProd _ = gstructuredProd (Proxy :: Proxy f) - -instance Structured c => GStructuredProd (K1 i c) where - gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs - -instance GStructuredProd U1 where - gstructuredProd _ = id - -instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where - gstructuredProd _ xs - = gstructuredProd (Proxy :: Proxy f) - $ gstructuredProd (Proxy :: Proxy g) xs - -------------------------------------------------------------------------------- --- instances -------------------------------------------------------------------------------- - -instance Structured () -instance Structured Bool -instance Structured Ordering - -instance Structured Char where structure = nominalStructure -instance Structured Int where structure = nominalStructure -instance Structured Integer where structure = nominalStructure - -instance Structured Data.Word.Word where structure = nominalStructure - -instance Structured Int8 where structure = nominalStructure -instance Structured Int16 where structure = nominalStructure -instance Structured Int32 where structure = nominalStructure -instance Structured Int64 where structure = nominalStructure - -instance Structured Word8 where structure = nominalStructure -instance Structured Word16 where structure = nominalStructure -instance Structured Word32 where structure = nominalStructure -instance Structured Word64 where structure = nominalStructure - -instance Structured Float where structure = nominalStructure -instance Structured Double where structure = nominalStructure - -instance Structured a => Structured (Maybe a) -instance (Structured a, Structured b) => Structured (Either a b) -instance Structured a => Structured (Ratio a) where structure = containerStructure -instance Structured a => Structured [a] where structure = containerStructure -instance Structured a => Structured (NonEmpty a) where structure = containerStructure - -instance (Structured a1, Structured a2) => Structured (a1, a2) -instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) -instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) -instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) - -instance Structured BS.ByteString where structure = nominalStructure -instance Structured LBS.ByteString where structure = nominalStructure - -instance Structured T.Text where structure = nominalStructure -instance Structured LT.Text where structure = nominalStructure - -instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ] -instance (Structured k) => Structured (Set.Set k) where structure = containerStructure -instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure -instance Structured IS.IntSet where structure = nominalStructure -instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure - -instance Structured Time.UTCTime where structure = nominalStructure -instance Structured Time.DiffTime where structure = nominalStructure -instance Structured Time.UniversalTime where structure = nominalStructure -instance Structured Time.NominalDiffTime where structure = nominalStructure -instance Structured Time.Day where structure = nominalStructure -instance Structured Time.TimeZone where structure = nominalStructure -instance Structured Time.TimeOfDay where structure = nominalStructure -instance Structured Time.LocalTime where structure = nominalStructure - --- Proxy isn't Typeable in base-4.8 / base - --- #if __GLASGOW_HASKELL__ >= 800 --- instance (Typeable k, Typeable (a :: k)) => Structured (Proxy a) --- #else --- instance (Typeable a) => Structured (Proxy a) where --- structure p = Structure (typeRep p) 0 "Proxy" [("Proxy",[])] --- #endif diff --git a/src/Distribution/Utils/UnionFind.hs b/src/Distribution/Utils/UnionFind.hs --- a/src/Distribution/Utils/UnionFind.hs +++ b/src/Distribution/Utils/UnionFind.hs @@ -1,27 +1,27 @@ {-# LANGUAGE NondecreasingIndentation #-} + -- | A simple mutable union-find data structure. -- -- It is used in a unification algorithm for backpack mix-in linking. -- -- This implementation is based off of the one in \"The Essence of ML Type -- Inference\". (N.B. the union-find package is also based off of this.) --- -module Distribution.Utils.UnionFind ( - Point, - fresh, - find, - union, - equivalent, -) where +module Distribution.Utils.UnionFind + ( Point + , fresh + , find + , union + , equivalent + ) where -import Data.STRef import Control.Monad import Control.Monad.ST +import Data.STRef -- | A variable which can be unified; alternately, this can be thought -- of as an equivalence class with a distinguished representative. newtype Point s a = Point (STRef s (Link s a)) - deriving (Eq) + deriving (Eq) -- | Mutable write to a 'Point' writePoint :: Point s a -> Link s a -> ST s () @@ -35,39 +35,41 @@ -- the representative element of an equivalence class, or a link to -- the 'Point' that actually stores the representative type. data Link s a - -- NB: it is too bad we can't say STRef Int#; the weights remain boxed - = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) - | Link {-# UNPACK #-} !(Point s a) + = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed + Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a) + | Link {-# UNPACK #-} !(Point s a) -- | Create a fresh equivalence class with one element. fresh :: a -> ST s (Point s a) fresh desc = do - weight <- newSTRef 1 - descriptor <- newSTRef desc - Point `fmap` newSTRef (Info weight descriptor) + weight <- newSTRef 1 + descriptor <- newSTRef desc + Point `fmap` newSTRef (Info weight descriptor) -- | Flatten any chains of links, returning a 'Point' -- which points directly to the canonical representation. repr :: Point s a -> ST s (Point s a) -repr point = readPoint point >>= \r -> - case r of - Link point' -> do +repr point = + readPoint point >>= \r -> + case r of + Link point' -> do point'' <- repr point' when (point'' /= point') $ do - writePoint point =<< readPoint point' + writePoint point =<< readPoint point' return point'' - Info _ _ -> return point + Info _ _ -> return point -- | Return the canonical element of an equivalence -- class 'Point'. find :: Point s a -> ST s a find point = - -- Optimize length 0 and 1 case at expense of - -- general case - readPoint point >>= \r -> - case r of - Info _ d_ref -> readSTRef d_ref - Link point' -> readPoint point' >>= \r' -> + -- Optimize length 0 and 1 case at expense of + -- general case + readPoint point >>= \r -> + case r of + Info _ d_ref -> readSTRef d_ref + Link point' -> + readPoint point' >>= \r' -> case r' of Info _ d_ref -> readSTRef d_ref Link _ -> repr point >>= find @@ -76,26 +78,26 @@ -- a canonical element. Keeps the descriptor of point2. union :: Point s a -> Point s a -> ST s () union refpoint1 refpoint2 = do - point1 <- repr refpoint1 - point2 <- repr refpoint2 - when (point1 /= point2) $ do + point1 <- repr refpoint1 + point2 <- repr refpoint2 + when (point1 /= point2) $ do l1 <- readPoint point1 l2 <- readPoint point2 case (l1, l2) of - (Info wref1 dref1, Info wref2 dref2) -> do - weight1 <- readSTRef wref1 - weight2 <- readSTRef wref2 - -- Should be able to optimize the == case separately - if weight1 >= weight2 - then do - writePoint point2 (Link point1) - -- The weight calculation here seems a bit dodgy - writeSTRef wref1 (weight1 + weight2) - writeSTRef dref1 =<< readSTRef dref2 - else do - writePoint point1 (Link point2) - writeSTRef wref2 (weight1 + weight2) - _ -> error "UnionFind.union: repr invariant broken" + (Info wref1 dref1, Info wref2 dref2) -> do + weight1 <- readSTRef wref1 + weight2 <- readSTRef wref2 + -- Should be able to optimize the == case separately + if weight1 >= weight2 + then do + writePoint point2 (Link point1) + -- The weight calculation here seems a bit dodgy + writeSTRef wref1 (weight1 + weight2) + writeSTRef dref1 =<< readSTRef dref2 + else do + writePoint point1 (Link point2) + writeSTRef wref2 (weight1 + weight2) + _ -> error "UnionFind.union: repr invariant broken" -- | Test if two points are in the same equivalence class. equivalent :: Point s a -> Point s a -> ST s Bool diff --git a/src/Distribution/Verbosity.hs b/src/Distribution/Verbosity.hs --- a/src/Distribution/Verbosity.hs +++ b/src/Distribution/Verbosity.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- + +-- Verbosity for Cabal functions. + -- | -- Module : Distribution.Verbosity -- Copyright : Ian Lynagh 2007 @@ -21,113 +23,131 @@ -- settings (e.g., so that you can trace only particular things you -- are interested in.) It's important to note that the instances -- for 'Verbosity' assume that this does not exist. - --- Verbosity for Cabal functions. +module Distribution.Verbosity + ( -- * Verbosity + Verbosity + , silent + , normal + , verbose + , deafening + , moreVerbose + , lessVerbose + , isVerboseQuiet + , intToVerbosity + , flagToVerbosity + , showForCabal + , showForGHC + , verboseNoFlags + , verboseHasFlags + , modifyVerbosity -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, isVerboseQuiet, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC, - verboseNoFlags, verboseHasFlags, - modifyVerbosity, + -- * Call stacks + , verboseCallSite + , verboseCallStack + , isVerboseCallSite + , isVerboseCallStack - -- * Call stacks - verboseCallSite, verboseCallStack, - isVerboseCallSite, isVerboseCallStack, + -- * Output markets + , verboseMarkOutput + , isVerboseMarkOutput + , verboseUnmarkOutput - -- * Output markets - verboseMarkOutput, isVerboseMarkOutput, - verboseUnmarkOutput, + -- * Line wrapping + , verboseNoWrap + , isVerboseNoWrap - -- * line-wrapping - verboseNoWrap, isVerboseNoWrap, + -- * Time stamps + , verboseTimestamp + , isVerboseTimestamp + , verboseNoTimestamp - -- * timestamps - verboseTimestamp, isVerboseTimestamp, - verboseNoTimestamp, + -- * Stderr + , verboseStderr + , isVerboseStderr + , verboseNoStderr - -- * Stderr - verboseStderr, isVerboseStderr, - verboseNoStderr, + -- * No warnings + , verboseNoWarn + , isVerboseNoWarn ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () import Distribution.ReadE import Data.List (elemIndex) import Distribution.Parsec import Distribution.Pretty -import Distribution.Verbosity.Internal import Distribution.Utils.Generic (isAsciiAlpha) +import Distribution.Verbosity.Internal import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP -data Verbosity = Verbosity { - vLevel :: VerbosityLevel, - vFlags :: Set VerbosityFlag, - vQuiet :: Bool - } deriving (Generic, Show, Read, Typeable) +data Verbosity = Verbosity + { vLevel :: VerbosityLevel + , vFlags :: Set VerbosityFlag + , vQuiet :: Bool + } + deriving (Generic, Show, Read) mkVerbosity :: VerbosityLevel -> Verbosity -mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False } +mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False} instance Eq Verbosity where - x == y = vLevel x == vLevel y + x == y = vLevel x == vLevel y instance Ord Verbosity where - compare x y = compare (vLevel x) (vLevel y) + compare x y = compare (vLevel x) (vLevel y) instance Enum Verbosity where - toEnum = mkVerbosity . toEnum - fromEnum = fromEnum . vLevel + toEnum = mkVerbosity . toEnum + fromEnum = fromEnum . vLevel instance Bounded Verbosity where - minBound = mkVerbosity minBound - maxBound = mkVerbosity maxBound + minBound = mkVerbosity minBound + maxBound = mkVerbosity maxBound instance Binary Verbosity instance Structured Verbosity --- We shouldn't print /anything/ unless an error occurs in silent mode +-- | In 'silent' mode, we should not print /anything/ unless an error occurs. silent :: Verbosity silent = mkVerbosity Silent --- Print stuff we want to see by default +-- | Print stuff we want to see by default. normal :: Verbosity normal = mkVerbosity Normal --- Be more verbose about what's going on +-- | Be more verbose about what's going on. verbose :: Verbosity verbose = mkVerbosity Verbose --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too +-- | Not only are we verbose ourselves (perhaps even noisier than when +-- being 'verbose'), but we tell everything we run to be verbose too. deafening :: Verbosity deafening = mkVerbosity Deafening +-- | Increase verbosity level, but stay 'silent' if we are. moreVerbose :: Verbosity -> Verbosity moreVerbose v = - case vLevel v of - Silent -> v -- silent should stay silent - Normal -> v { vLevel = Verbose } - Verbose -> v { vLevel = Deafening } - Deafening -> v + case vLevel v of + Silent -> v -- silent should stay silent + Normal -> v{vLevel = Verbose} + Verbose -> v{vLevel = Deafening} + Deafening -> v +-- | Decrease verbosity level, but stay 'deafening' if we are. lessVerbose :: Verbosity -> Verbosity lessVerbose v = - verboseQuiet $ + verboseQuiet $ case vLevel v of - Deafening -> v -- deafening stays deafening - Verbose -> v { vLevel = Normal } - Normal -> v { vLevel = Silent } - Silent -> v + Deafening -> v -- deafening stays deafening + Verbose -> v{vLevel = Normal} + Normal -> v{vLevel = Silent} + Silent -> v -- | Combinator for transforming verbosity level while retaining the -- original hidden state. @@ -141,8 +161,9 @@ -- -- @since 2.0.1.0 modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity -modifyVerbosity f v = v { vLevel = vLevel (f v) } +modifyVerbosity f v = v{vLevel = vLevel (f v)} +-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'. intToVerbosity :: Int -> Maybe Verbosity intToVerbosity 0 = Just (mkVerbosity Silent) intToVerbosity 1 = Just (mkVerbosity Normal) @@ -171,79 +192,82 @@ -- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False}) -- -- /Note:/ this parser will eat trailing spaces. --- instance Parsec Verbosity where - parsec = parsecVerbosity + parsec = parsecVerbosity instance Pretty Verbosity where - pretty = PP.text . showForCabal + pretty = PP.text . showForCabal parsecVerbosity :: CabalParsing m => m Verbosity parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity where parseIntVerbosity = do - i <- P.integral - case intToVerbosity i of - Just v -> return v - Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" + i <- P.integral + case intToVerbosity i of + Just v -> return v + Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3" parseStringVerbosity = do - level <- parseVerbosityLevel - _ <- P.spaces - flags <- many (parseFlag <* P.spaces) - return $ foldl' (flip ($)) (mkVerbosity level) flags + level <- parseVerbosityLevel + _ <- P.spaces + flags <- many (parseFlag <* P.spaces) + return $ foldl' (flip ($)) (mkVerbosity level) flags parseVerbosityLevel = do - token <- P.munch1 isAsciiAlpha - case token of - "silent" -> return Silent - "normal" -> return Normal - "verbose" -> return Verbose - "debug" -> return Deafening - "deafening" -> return Deafening - _ -> P.unexpected $ "Bad verbosity level: " ++ token + token <- P.munch1 isAsciiAlpha + case token of + "silent" -> return Silent + "normal" -> return Normal + "verbose" -> return Verbose + "debug" -> return Deafening + "deafening" -> return Deafening + _ -> P.unexpected $ "Bad verbosity level: " ++ token parseFlag = do - _ <- P.char '+' - token <- P.munch1 isAsciiAlpha - case token of - "callsite" -> return verboseCallSite - "callstack" -> return verboseCallStack - "nowrap" -> return verboseNoWrap - "markoutput" -> return verboseMarkOutput - "timestamp" -> return verboseTimestamp - "stderr" -> return verboseStderr - "stdout" -> return verboseNoStderr - _ -> P.unexpected $ "Bad verbosity flag: " ++ token + _ <- P.char '+' + token <- P.munch1 isAsciiAlpha + case token of + "callsite" -> return verboseCallSite + "callstack" -> return verboseCallStack + "nowrap" -> return verboseNoWrap + "markoutput" -> return verboseMarkOutput + "timestamp" -> return verboseTimestamp + "stderr" -> return verboseStderr + "stdout" -> return verboseNoStderr + "nowarn" -> return verboseNoWarn + _ -> P.unexpected $ "Bad verbosity flag: " ++ token flagToVerbosity :: ReadE Verbosity flagToVerbosity = parsecToReadE id parsecVerbosity showForCabal :: Verbosity -> String showForCabal v - | Set.null (vFlags v) - = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] - | otherwise - = unwords - $ showLevel (vLevel v) - : concatMap showFlag (Set.toList (vFlags v)) + | Set.null (vFlags v) = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, verbose, deafening] + | otherwise = + unwords $ + showLevel (vLevel v) + : concatMap showFlag (Set.toList (vFlags v)) where - showLevel Silent = "silent" - showLevel Normal = "normal" - showLevel Verbose = "verbose" + showLevel Silent = "silent" + showLevel Normal = "normal" + showLevel Verbose = "verbose" showLevel Deafening = "debug" - showFlag VCallSite = ["+callsite"] - showFlag VCallStack = ["+callstack"] - showFlag VNoWrap = ["+nowrap"] + showFlag VCallSite = ["+callsite"] + showFlag VCallStack = ["+callstack"] + showFlag VNoWrap = ["+nowrap"] showFlag VMarkOutput = ["+markoutput"] - showFlag VTimestamp = ["+timestamp"] - showFlag VStderr = ["+stderr"] + showFlag VTimestamp = ["+timestamp"] + showFlag VStderr = ["+stderr"] + showFlag VNoWarn = ["+nowarn"] showForGHC :: Verbosity -> String -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex +showForGHC v = + maybe (error "unknown verbosity") show $ + elemIndex v [silent, normal, __, verbose, deafening] + where + __ = silent -- this will be always ignored by elemIndex -- | Turn on verbose call-site printing when we log. verboseCallSite :: Verbosity -> Verbosity @@ -266,9 +290,9 @@ verboseNoWrap :: Verbosity -> Verbosity verboseNoWrap = verboseFlag VNoWrap --- | Mark the verbosity as quiet +-- | Mark the verbosity as quiet. verboseQuiet :: Verbosity -> Verbosity -verboseQuiet v = v { vQuiet = True } +verboseQuiet v = v{vQuiet = True} -- | Turn on timestamps for log messages. verboseTimestamp :: Verbosity -> Verbosity @@ -278,29 +302,33 @@ verboseNoTimestamp :: Verbosity -> Verbosity verboseNoTimestamp = verboseNoFlag VTimestamp --- | Turn on timestamps for log messages. +-- | Switch logging to 'stderr'. -- -- @since 3.4.0.0 verboseStderr :: Verbosity -> Verbosity verboseStderr = verboseFlag VStderr --- | Turn off timestamps for log messages. +-- | Switch logging to 'stdout'. -- -- @since 3.4.0.0 verboseNoStderr :: Verbosity -> Verbosity verboseNoStderr = verboseNoFlag VStderr --- | Helper function for flag enabling functions +-- | Turn off warnings for log messages. +verboseNoWarn :: Verbosity -> Verbosity +verboseNoWarn = verboseFlag VNoWarn + +-- | Helper function for flag enabling functions. verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) } +verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)} --- | Helper function for flag disabling functions +-- | Helper function for flag disabling functions. verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity) -verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) } +verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)} --- | Turn off all flags +-- | Turn off all flags. verboseNoFlags :: Verbosity -> Verbosity -verboseNoFlags v = v { vFlags = Set.empty } +verboseNoFlags v = v{vFlags = Set.empty} verboseHasFlags :: Verbosity -> Bool verboseHasFlags = not . Set.null . vFlags @@ -321,7 +349,7 @@ isVerboseNoWrap :: Verbosity -> Bool isVerboseNoWrap = isVerboseFlag VNoWrap --- | Test if we had called 'lessVerbose' on the verbosity +-- | Test if we had called 'lessVerbose' on the verbosity. isVerboseQuiet :: Verbosity -> Bool isVerboseQuiet = vQuiet @@ -329,11 +357,15 @@ isVerboseTimestamp :: Verbosity -> Bool isVerboseTimestamp = isVerboseFlag VTimestamp --- | Test if we should output to stderr when we log. +-- | Test if we should output to 'stderr' when we log. -- -- @since 3.4.0.0 isVerboseStderr :: Verbosity -> Bool isVerboseStderr = isVerboseFlag VStderr + +-- | Test if we should output warnings when we log. +isVerboseNoWarn :: Verbosity -> Bool +isVerboseNoWarn = isVerboseFlag VNoWarn -- | Helper function for flag testing functions. isVerboseFlag :: VerbosityFlag -> Verbosity -> Bool diff --git a/src/Distribution/Verbosity/Internal.hs b/src/Distribution/Verbosity/Internal.hs --- a/src/Distribution/Verbosity/Internal.hs +++ b/src/Distribution/Verbosity/Internal.hs @@ -1,27 +1,29 @@ -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} + module Distribution.Verbosity.Internal - ( VerbosityLevel(..) - , VerbosityFlag(..) + ( VerbosityLevel (..) + , VerbosityFlag (..) ) where -import Prelude () import Distribution.Compat.Prelude +import Prelude () data VerbosityLevel = Silent | Normal | Verbose | Deafening - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityLevel instance Structured VerbosityLevel data VerbosityFlag - = VCallStack - | VCallSite - | VNoWrap - | VMarkOutput - | VTimestamp - | VStderr -- ^ @since 3.4.0.0 - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable) + = VCallStack + | VCallSite + | VNoWrap + | VMarkOutput + | VTimestamp + | -- | @since 3.4.0.0 + VStderr + | VNoWarn + deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded) instance Binary VerbosityFlag instance Structured VerbosityFlag diff --git a/src/Distribution/Version.hs b/src/Distribution/Version.hs deleted file mode 100644 --- a/src/Distribution/Version.hs +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- License : BSD3 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data --- types. Version ranges are like @\">= 1.2 && < 2\"@. - -module Distribution.Version ( - -- * Package versions - Version, - version0, - mkVersion, - mkVersion', - versionNumbers, - nullVersion, - alterVersion, - - -- * Version ranges - VersionRange, - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - majorBoundVersion, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - normaliseVersionRange, - stripParensVersionRange, - hasUpperBound, - hasLowerBound, - - -- ** Cata & ana - VersionRangeF (..), - cataVersionRange, - anaVersionRange, - hyloVersionRange, - projectVersionRange, - embedVersionRange, - - -- ** Utilities - wildcardUpperBound, - majorUpperBound, - - -- ** Modification - removeUpperBound, - removeLowerBound, - transformCaret, - transformCaretUpper, - transformCaretLower, - - -- * Version intervals view - asVersionIntervals, - VersionInterval(..), - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - unVersionIntervals, - - ) where - -import Distribution.Types.Version -import Distribution.Types.VersionRange -import Distribution.Types.VersionInterval - -------------------------------------------------------------------------------- --- Utilities on VersionRange requiring VersionInterval -------------------------------------------------------------------------------- - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - -------------------------------------------------------------------------------- --- Transformations -------------------------------------------------------------------------------- - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (unVersionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - --- | Given a version range, remove the highest upper bound. Example: @(>= 1 && < --- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@. -removeUpperBound :: VersionRange -> VersionRange -removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals - --- | Given a version range, remove the lowest lower bound. --- Example: @(>= 1 && < 3) || (>= 4 && < 5)@ is converted to --- @(>= 0 && < 3) || (>= 4 && < 5)@. -removeLowerBound :: VersionRange -> VersionRange -removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals - --- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@ --- --- @since 3.6.0.0 --- -transformCaret :: VersionRange -> VersionRange -transformCaret = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr - --- | Rewrite @^>= x.y.z@ into @>= x.y.z@ --- --- @since 3.6.0.0 --- -transformCaretUpper :: VersionRange -> VersionRange -transformCaretUpper = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = orLaterVersion v - embed vr = embedVersionRange vr - --- | Rewrite @^>= x.y.z@ into @ VersionRange -transformCaretLower = hyloVersionRange embed projectVersionRange where - embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v) - embed vr = embedVersionRange vr diff --git a/src/Distribution/ZinzaPrelude.hs b/src/Distribution/ZinzaPrelude.hs --- a/src/Distribution/ZinzaPrelude.hs +++ b/src/Distribution/ZinzaPrelude.hs @@ -1,40 +1,41 @@ -- | A small prelude used in @zinza@ generated -- template modules. -module Distribution.ZinzaPrelude ( - Writer, - execWriter, - tell, +module Distribution.ZinzaPrelude + ( Writer + , execWriter + , tell + -- * Re-exports - forM_, - Generic, - PackageName, - Version, - prettyShow - ) where + , forM_ + , Generic + , PackageName + , Version + , prettyShow + ) where import Distribution.Compat.Prelude import Prelude () -import Control.Monad (forM_) -import Distribution.Pretty (prettyShow) +import Control.Monad (forM_) +import Distribution.Pretty (prettyShow) import Distribution.Types.PackageName (PackageName) -import Distribution.Types.Version (Version) +import Distribution.Types.Version (Version) -newtype Writer a = W { unW :: ShowS -> (ShowS, a) } +newtype Writer a = W {unW :: ShowS -> (ShowS, a)} instance Functor Writer where - fmap = liftM + fmap = liftM instance Applicative Writer where - pure x = W $ \ss -> (ss, x) - (<*>) = ap + pure x = W $ \ss -> (ss, x) + (<*>) = ap instance Monad Writer where - return = pure - m >>= k = W $ \s1 -> - let (s2, x) = unW m s1 - in unW (k x) s2 - {-# INLINE (>>=) #-} + return = pure + m >>= k = W $ \s1 -> + let (s2, x) = unW m s1 + in unW (k x) s2 + {-# INLINE (>>=) #-} execWriter :: Writer a -> String execWriter w = fst (unW w id) "" diff --git a/src/Language/Haskell/Extension.hs b/src/Language/Haskell/Extension.hs deleted file mode 100644 --- a/src/Language/Haskell/Extension.hs +++ /dev/null @@ -1,933 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- License : BSD3 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- Haskell language dialects and extensions - -module Language.Haskell.Extension ( - Language(..), - knownLanguages, - classifyLanguage, - - Extension(..), - KnownExtension(..), - deprecatedExtensions, - classifyExtension, - ) where - -import qualified Prelude (head) -import Distribution.Compat.Prelude - -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - -import Distribution.Parsec -import Distribution.Pretty - -import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp - --- ------------------------------------------------------------ --- * Language --- ------------------------------------------------------------ - --- | This represents a Haskell language dialect. --- --- Language 'Extension's are interpreted relative to one of these base --- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | The GHC2021 collection of language extensions. - -- - | GHC2021 - - -- | An unknown language, identified by its name. - | UnknownLanguage String - deriving (Generic, Show, Read, Eq, Typeable, Data) - -instance Binary Language -instance Structured Language - -instance NFData Language where rnf = genericRnf - --- | List of known (supported) languages for GHC -knownLanguages :: [Language] -knownLanguages = [Haskell98, Haskell2010, GHC2021] - -instance Pretty Language where - pretty (UnknownLanguage other) = Disp.text other - pretty other = Disp.text (show other) - -instance Parsec Language where - parsec = classifyLanguage <$> P.munch1 isAlphaNum - -classifyLanguage :: String -> Language -classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str - where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- Note: if you add a new 'KnownExtension': --- --- * also add it to the Distribution.Simple.X.languageExtensions lists --- (where X is each compiler: GHC, UHC, HaskellSuite) --- --- | This represents language extensions beyond a base 'Language' definition --- (such as 'Haskell98') that are supported by some implementations, usually --- in some special mode. --- --- Where applicable, references are given to an implementation's --- official documentation. - -data Extension = - -- | Enable a known extension - EnableExtension KnownExtension - - -- | Disable a known extension - | DisableExtension KnownExtension - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - - deriving (Generic, Show, Read, Eq, Ord, Typeable, Data) - -instance Binary Extension -instance Structured Extension - -instance NFData Extension where rnf = genericRnf - -data KnownExtension = - - -- | Allow overlapping class instances, provided there is a unique - -- most specific instance for each use. - -- - -- * - 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. - -- - -- * - | 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. - -- - -- * - | IncoherentInstances - - -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'. - -- - -- Old description: Allow recursive bindings in @do@ blocks, using - -- the @rec@ keyword. See also 'RecursiveDo'. - | DoRec - - -- | Allow recursive bindings in @do@ blocks, using the @rec@ - -- keyword, or @mdo@, a variant of @do@. - -- - -- * - | RecursiveDo - - -- | Provide syntax for writing list comprehensions which iterate - -- over several lists together, like the 'zipWith' family of - -- functions. - -- - -- * - | ParallelListComp - - -- | Allow multiple parameters in a type class. - -- - -- * - | MultiParamTypeClasses - - -- | Enable the dreaded monomorphism restriction. - -- - -- * - | 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. - -- - -- * - | FunctionalDependencies - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - -- - -- * - | Rank2Types - - -- | Allow a universally-quantified type to occur on the left of a - -- function arrow. - -- - -- * - | RankNTypes - - -- | /(deprecated)/ A synonym for 'RankNTypes'. - -- - -- Old description: Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - -- - -- * - | PolymorphicComponents - - -- | Allow existentially-quantified data constructors. - -- - -- * - | ExistentialQuantification - - -- | Cause a type variable in a signature, which has an explicit - -- @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - -- - -- * - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | Enable implicit function parameters with dynamic scope. - -- - -- * - | ImplicitParams - - -- | Relax some restrictions on the form of the context of a type - -- signature. - -- - -- * - | FlexibleContexts - - -- | Relax some restrictions on the form of the context of an - -- instance declaration. - -- - -- * - | FlexibleInstances - - -- | Allow data type declarations with no constructors. - -- - -- * - | EmptyDataDecls - - -- | Run the C preprocessor on Haskell source code. - -- - -- * - | CPP - - -- | Allow an explicit kind signature giving the kind of types over - -- which a type variable ranges. - -- - -- * - | KindSignatures - - -- | Enable a form of pattern which forces evaluation before an - -- attempted match, and a form of strict @let@/@where@ binding. - -- - -- * - | BangPatterns - - -- | Allow type synonyms in instance heads. - -- - -- * - | TypeSynonymInstances - - -- | Enable Template Haskell, a system for compile-time - -- metaprogramming. - -- - -- * - | TemplateHaskell - - -- | Enable the Foreign Function Interface. In GHC, implements the - -- standard Haskell 98 Foreign Function Interface Addendum, plus - -- some GHC-specific extensions. - -- - -- * - | ForeignFunctionInterface - - -- | Enable arrow notation. - -- - -- * - | Arrows - - -- | /(deprecated)/ Enable generic type classes, with default instances defined in - -- terms of the algebraic structure of a type. - -- - -- * - | 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. - -- - -- * - | ImplicitPrelude - - -- | Enable syntax for implicitly binding local names corresponding - -- to the field names of a record. Puns bind specific names, unlike - -- 'RecordWildCards'. - -- - -- * - | NamedFieldPuns - - -- | Enable a form of guard which matches a pattern and binds - -- variables. - -- - -- * - | PatternGuards - - -- | Allow a type declared with @newtype@ to use @deriving@ for any - -- class with an instance for the underlying type. - -- - -- * - | GeneralizedNewtypeDeriving - - -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1. - | GeneralisedNewtypeDeriving - - -- | Enable the \"Trex\" extensible records system. - -- - -- * - | ExtensibleRecords - - -- | Enable type synonyms which are transparent in some definitions - -- and opaque elsewhere, as a way of implementing abstract - -- datatypes. - -- - -- * - | RestrictedTypeSynonyms - - -- | Enable an alternate syntax for string literals, - -- with string templating. - -- - -- * - | HereDocuments - - -- | Allow the character @#@ as a postfix modifier on identifiers. - -- Also enables literal syntax for unboxed values. - -- - -- * - | MagicHash - - -- | Allow data types and type synonyms which are indexed by types, - -- i.e. ad-hoc polymorphism for types. - -- - -- * - | TypeFamilies - - -- | Allow a standalone declaration which invokes the type class - -- @deriving@ mechanism. - -- - -- * - | StandaloneDeriving - - -- | Allow certain Unicode characters to stand for certain ASCII - -- character sequences, e.g. keywords and punctuation. - -- - -- * - | UnicodeSyntax - - -- | Allow the use of unboxed types as foreign types, e.g. in - -- @foreign import@ and @foreign export@. - -- - -- * - | UnliftedFFITypes - - -- | Enable interruptible FFI. - -- - -- * - | InterruptibleFFI - - -- | Allow use of CAPI FFI calling convention (@foreign import capi@). - -- - -- * - | CApiFFI - - -- | Defer validity checking of types until after expanding type - -- synonyms, relaxing the constraints on how synonyms may be used. - -- - -- * - | 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'. - -- - -- * - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | Allow a record field name to be disambiguated by the type of - -- the record it's in. - -- - -- * - | DisambiguateRecordFields - - -- | Enable traditional record syntax (as supported by Haskell 98) - -- - -- * - | TraditionalRecordSyntax - - -- | Enable overloading of string literals using a type class, much - -- like integer literals. - -- - -- * - | OverloadedStrings - - -- | Enable generalized algebraic data types, in which type - -- variables may be instantiated on a per-constructor basis. Implies - -- 'GADTSyntax'. - -- - -- * - | GADTs - - -- | Enable GADT syntax for declaring ordinary algebraic datatypes. - -- - -- * - | GADTSyntax - - -- | /(deprecated)/ Has no effect. - -- - -- Old description: Make pattern bindings monomorphic. - -- - -- * - | MonoPatBinds - - -- | Relax the requirements on mutually-recursive polymorphic - -- functions. - -- - -- * - | RelaxedPolyRec - - -- | Allow default instantiation of polymorphic types in more - -- situations. - -- - -- * - | ExtendedDefaultRules - - -- | Enable unboxed tuples. - -- - -- * - | UnboxedTuples - - -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and - -- 'Data.Generics.Data'. - -- - -- * - | DeriveDataTypeable - - -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'. - -- - -- * - | DeriveGeneric - - -- | Enable support for default signatures. - -- - -- * - | DefaultSignatures - - -- | Allow type signatures to be specified in instance declarations. - -- - -- * - | InstanceSigs - - -- | Allow a class method's type to place additional constraints on - -- a class type variable. - -- - -- * - | ConstrainedClassMethods - - -- | Allow imports to be qualified by the package name the module is - -- intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - -- - -- * - | PackageImports - - -- | /(deprecated)/ Allow a type variable to be instantiated at a - -- polymorphic type. - -- - -- * - | ImpredicativeTypes - - -- | /(deprecated)/ Change the syntax for qualified infix operators. - -- - -- * - | NewQualifiedOperators - - -- | Relax the interpretation of left operator sections to allow - -- unary postfix operators. - -- - -- * - | PostfixOperators - - -- | Enable quasi-quotation, a mechanism for defining new concrete - -- syntax for expressions and patterns. - -- - -- * - | QuasiQuotes - - -- | Enable generalized list comprehensions, supporting operations - -- such as sorting and grouping. - -- - -- * - | TransformListComp - - -- | Enable monad comprehensions, which generalise the list - -- comprehension syntax to work for any monad. - -- - -- * - | MonadComprehensions - - -- | Enable view patterns, which match a value by applying a - -- function and matching on the result. - -- - -- * - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . 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)@. - -- - -- * - | 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. - -- - -- * - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Enable support for multi-way @if@-expressions. - -- - -- * - | MultiWayIf - - -- | Enable support lambda-@case@ expressions. - -- - -- * - | LambdaCase - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - -- - -- * - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - -- - -- * - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - -- - -- * - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - -- - -- * - | MonoLocalBinds - - -- | Enable @deriving@ for the 'Data.Functor.Functor' class. - -- - -- * - | DeriveFunctor - - -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class. - -- - -- * - | DeriveTraversable - - -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class. - -- - -- * - | DeriveFoldable - - -- | Enable non-decreasing indentation for @do@ blocks. - -- - -- * - | NondecreasingIndentation - - -- | Allow imports to be qualified with a safe keyword that requires - -- the imported module be trusted as according to the Safe Haskell - -- definition of trust. - -- - -- > import safe Network.Socket - -- - -- * - | SafeImports - - -- | Compile a module in the Safe, Safe Haskell mode -- a restricted - -- form of the Haskell language to ensure type safety. - -- - -- * - | 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. - -- - -- * - | Trustworthy - - -- | Compile a module in the Unsafe, Safe Haskell mode so that - -- modules compiled using Safe, Safe Haskell mode can't import it. - -- - -- * - | 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. - -- - -- * - | ConstraintKinds - - -- | Enable kind polymorphism. - -- - -- * - | PolyKinds - - -- | Enable datatype promotion. - -- - -- * - | DataKinds - - -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/. - -- - -- * - | ParallelArrays - - -- | Enable explicit role annotations, like in (@type role Foo representational representational@). - -- - -- * - | RoleAnnotations - - -- | Enable overloading of list literals, arithmetic sequences and - -- list patterns using the 'IsList' type class. - -- - -- * - | OverloadedLists - - -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled. - -- - -- * - | EmptyCase - - -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'. - -- - -- Old description: Triggers the generation of derived 'Typeable' - -- instances for every datatype and type class declaration. - -- - -- * - | AutoDeriveTypeable - - -- | Desugars negative literals directly (without using negate). - -- - -- * - | NegativeLiterals - - -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@). - -- - -- * - | BinaryLiterals - - -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'. - -- - -- * - | NumDecimals - - -- | Enable support for type classes with no type parameter. - -- - -- * - | NullaryTypeClasses - - -- | Enable explicit namespaces in module import/export lists. - -- - -- * - | ExplicitNamespaces - - -- | Allow the user to write ambiguous types, and the type inference engine to infer them. - -- - -- * - | AllowAmbiguousTypes - - -- | Enable @foreign import javascript@. - | JavaScriptFFI - - -- | Allow giving names to and abstracting over patterns. - -- - -- * - | 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. - -- - -- * - | PartialTypeSignatures - - -- | Allow named placeholders written with a leading underscore inside type - -- signatures. Wildcards with the same name unify to the same type. - -- - -- * - | NamedWildCards - - -- | Enable @deriving@ for any class. - -- - -- * - | DeriveAnyClass - - -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class. - -- - -- * - | DeriveLift - - -- | Enable support for 'static pointers' (and the @static@ - -- keyword) to refer to globally stable names, even across - -- different programs. - -- - -- * - | StaticPointers - - -- | Switches data type declarations to be strict by default (as if - -- they had a bang using @BangPatterns@), and allow opt-in field - -- laziness using @~@. - -- - -- * - | StrictData - - -- | Switches all pattern bindings to be strict by default (as if - -- they had a bang using @BangPatterns@), ordinary patterns are - -- recovered using @~@. Implies @StrictData@. - -- - -- * - | Strict - - -- | Allows @do@-notation for types that are @'Applicative'@ as well - -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use - -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible. - | ApplicativeDo - - -- | Allow records to use duplicated field labels for accessors. - | DuplicateRecordFields - - -- | Enable explicit type applications with the syntax @id \@Int@. - | TypeApplications - - -- | Dissolve the distinction between types and kinds, allowing the compiler - -- to reason about kind equality and therefore enabling GADTs to be promoted - -- to the type-level. - | TypeInType - - -- | Allow recursive (and therefore undecidable) super-class relationships. - | UndecidableSuperClasses - - -- | A temporary extension to help library authors check if their - -- code will compile with the new planned desugaring of fail. - | MonadFailDesugaring - - -- | A subset of @TemplateHaskell@ including only quoting. - | TemplateHaskellQuotes - - -- | Allows use of the @#label@ syntax. - | OverloadedLabels - - -- | Allow functional dependency annotations on type families to declare them - -- as injective. - | TypeFamilyDependencies - - -- | Allow multiple @deriving@ clauses, each optionally qualified with a - -- /strategy/. - | DerivingStrategies - - -- | Enable deriving instances via types of the same runtime representation. - -- Implies 'DerivingStrategies'. - | DerivingVia - - -- | Enable the use of unboxed sum syntax. - | UnboxedSums - - -- | Allow use of hexadecimal literal notation for floating-point values. - | HexFloatLiterals - - -- | Allow @do@ blocks etc. in argument position. - | BlockArguments - - -- | Allow use of underscores in numeric literals. - | NumericUnderscores - - -- | Allow @forall@ in constraints. - | QuantifiedConstraints - - -- | Have @*@ refer to @Type@. - | StarIsType - - -- | Liberalises deriving to provide instances for empty data types. - -- - -- * - | EmptyDataDeriving - - -- | Enable detection of complete user-supplied kind signatures. - | CUSKs - - -- | Allows the syntax @import M qualified@. - | ImportQualifiedPost - - -- | Allow the use of standalone kind signatures. - | StandaloneKindSignatures - - -- | Enable unlifted newtypes. - | UnliftedNewtypes - - -- | Use whitespace to determine whether the minus sign stands for negation or subtraction. - | LexicalNegation - - -- | Enable qualified do-notation desugaring. - | QualifiedDo - - -- | Enable linear types. - | LinearTypes - - -- | Enable the generation of selector functions corresponding to record fields. - | FieldSelectors - - -- | Enable the use of record dot-accessor and updater syntax - | OverloadedRecordDot - - -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred. - | UnliftedDatatypes - - deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data) - -instance Binary KnownExtension -instance Structured KnownExtension - -instance NFData KnownExtension where rnf = genericRnf - --- | Extensions that have been deprecated, possibly paired with another --- extension that replaces it. --- -deprecatedExtensions :: [(Extension, Maybe Extension)] -deprecatedExtensions = - [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) - , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) - ] --- NOTE: when adding deprecated extensions that have new alternatives --- we must be careful to make sure that the deprecation messages are --- valid. We must not recommend aliases that cannot be used with older --- compilers, perhaps by adding support in Cabal to translate the new --- name to the old one for older compilers. Otherwise we are in danger --- of the scenario in ticket #689. - -instance Pretty Extension where - pretty (UnknownExtension other) = Disp.text other - pretty (EnableExtension ke) = Disp.text (show ke) - pretty (DisableExtension ke) = Disp.text ("No" ++ show ke) - -instance Parsec Extension where - parsec = classifyExtension <$> P.munch1 isAlphaNum - -instance Pretty KnownExtension where - pretty ke = Disp.text (show ke) - -classifyExtension :: String -> Extension -classifyExtension string - = case classifyKnownExtension string of - Just ext -> EnableExtension ext - Nothing -> - case string of - 'N':'o':string' -> - case classifyKnownExtension string' of - Just ext -> DisableExtension ext - Nothing -> UnknownExtension string - _ -> UnknownExtension string - --- | 'read' for 'KnownExtension's is really really slow so for the Text --- instance --- what we do is make a simple table indexed off the first letter in the --- extension name. The extension names actually cover the range @'A'-'Z'@ --- pretty densely and the biggest bucket is 7 so it's not too bad. We just do --- a linear search within each bucket. --- --- This gives an order of magnitude improvement in parsing speed, and it'll --- also allow us to do case insensitive matches in future if we prefer. --- -classifyKnownExtension :: String -> Maybe KnownExtension -classifyKnownExtension "" = Nothing -classifyKnownExtension string@(c : _) - | inRange (bounds knownExtensionTable) c - = lookup string (knownExtensionTable ! c) - | otherwise = Nothing - -knownExtensionTable :: Array Char [(String, KnownExtension)] -knownExtensionTable = - accumArray (flip (:)) [] ('A', 'Z') - [ (Prelude.head str, (str, extension)) -- assume KnownExtension's Show returns a non-empty string - | extension <- [toEnum 0 ..] - , let str = show extension ]